{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module ProductMixAuction.Types
  ( -- * Basic types
    Units(..)
  , Price(..)
  , TweakedPrice(..)
  , TradeOff(..)
  , Ratio(..)

  , unitsToDouble
  , tweakedPriceToDouble
  , tradeOffToDouble
  , doubleToUnits

    -- * Labels
  , Good
  , B(..)
  , G(..)
  , BidderName(..)
  , mkBidderName

    -- * Rounding
  , ScaleFactor(..)
  , roundToScale
  , floorToScale
  , ceilingToScale
  , scaleDistance
  , showUnits

    -- * Generators
  , arbitraryUnits

    -- * Settings
  , jsonOptions
  , dropPrefix

    -- * Debugging
  , Verbosity(..)
  , ifDebug
  , debugPutStrLn
  , debugPrint
  ) where

import Control.Monad
import Data.Aeson.Types as A hiding (parseField)
import Data.Csv (FromField(..), ToField(..), FromRecord(..))
import Data.Default.Class
import Data.List
import qualified Data.Text as T
import GHC.Generics
import Numeric
import System.Random (Random)
import qualified Data.Vector as V
import qualified Test.QuickCheck as QC

dropPrefix :: String -> (String -> String)
dropPrefix pref s
  | pref `isPrefixOf` s = drop (length pref) s
  | otherwise           = error $ "dropPrefix: " ++ show pref ++
                                  " is not a prefix of " ++ show s

jsonOptions :: String -> A.Options
jsonOptions pref = A.defaultOptions
  { A.fieldLabelModifier = dropPrefix pref
  , A.sumEncoding = A.ObjectWithSingleField
  , A.omitNothingFields = True
  , A.unwrapUnaryRecords = True }

newtype Units = Units { _Units :: Double }
  deriving ( QC.Arbitrary, Enum, Eq, Floating, Fractional, FromJSON, Generic
           , Num, Ord, Random, Read, Real, RealFloat, RealFrac, Show
           , ToField, ToJSON
           )

instance Default Units where def = 1

-- | Parse empty cells as quantity 0.
instance FromField Units where
  parseField "" = pure 0
  parseField s  = doubleToUnits <$> parseField s


-- | Represents a price supplied by or presented to the user, which
-- will always be an integer.
newtype Price = Price { _Price :: Int }
  deriving (QC.Arbitrary, Enum, Eq, Integral, Ord, Read, Real, Show, Num, ToField, Random, ToJSON, FromJSON, Generic, Default)

instance Bounded Price where
  minBound = 0
  maxBound = Price maxBound

instance FromField Price where
  parseField "" = pure 0
  parseField s  = Price <$> parseField s

instance FromRecord Price where
  parseRecord v =
    case V.toList v of
      [p] -> parseField p
      _   -> mzero

-- | Represents a price used internally, which may be incremented by a
-- small fraction from the original integer price.
newtype TweakedPrice = TweakedPrice { _TweakedPrice :: Double }
  deriving (Enum, Eq, Fractional, Ord, Read, Real, RealFrac, Show, Num, ToJSON, FromJSON, Generic, Default)


-- | A trade-off coefficient for use representing asymmetric bids.
newtype TradeOff = TradeOff { _TradeOff :: Double }
  deriving (Enum, Eq, Num, Ord, Read, Show, ToJSON, FromJSON, Generic)

instance Default TradeOff where def = 1

instance ToField TradeOff where
  toField = toField . tradeOffToDouble

-- | Parse empty cells as trade-off 1 (symmetric).
instance FromField TradeOff where
  parseField "" = pure def
  parseField s  = doubleToTradeOff <$> parseField s


-- | A number between 0 and 1.
newtype Ratio = Ratio { _Ratio :: Double }
  deriving (Enum, Eq, Fractional, Num, Ord, Read, Show, ToJSON, FromJSON, Generic, Default)

instance QC.Arbitrary Ratio where
  arbitrary = Ratio <$> QC.choose (0, 1)

unitsToDouble :: Units -> Double
unitsToDouble = _Units

tweakedPriceToDouble :: TweakedPrice -> Double
tweakedPriceToDouble =  _TweakedPrice

tradeOffToDouble :: TradeOff -> Double
tradeOffToDouble = _TradeOff

doubleToUnits :: Double -> Units
doubleToUnits = Units

doubleToTradeOff :: Double -> TradeOff
doubleToTradeOff = TradeOff


-- | A scale factor represents the precision with which quantities
-- should be expressed as a number of decimal places.
newtype ScaleFactor = ScaleFactor { _ScaleFactor :: Int }
  deriving (Eq, Read, Show, Num, ToJSON, FromJSON, Generic)

instance Default ScaleFactor where
  def = ScaleFactor 1

-- | Round to given number of decimal places.
--
-- TODO: can this return a fixed-precision type, rather than abusing
-- floating-point like this?
roundToScale :: RealFrac a => ScaleFactor -> a -> a
roundToScale (ScaleFactor s) = (/e) . fromInteger . round . (* e)
  where
    e = 10 ^ s

-- | Round down to the given number of decimal places.
floorToScale :: RealFrac a => ScaleFactor -> a -> a
floorToScale (ScaleFactor s) = (/e) . fromInteger . floor . (* e)
  where
    e = 10 ^ s

-- | Round up to the given number of decimal places.
ceilingToScale :: RealFrac a => ScaleFactor -> a -> a
ceilingToScale (ScaleFactor s) = (/e) . fromInteger . ceiling . (* e)
  where
    e = 10 ^ s

-- | The distance between two successive points to which values will
-- be rounded.
scaleDistance :: ScaleFactor -> Double
scaleDistance (ScaleFactor s) = 1 / 10^s

-- | Show a quantity with the number of digits controlled by the
-- precision of the auction.
showUnits :: ScaleFactor -> Units -> String
showUnits (ScaleFactor sf) u = showFFloat (Just sf) (unitsToDouble u) ""


type Good = G

newtype G = G { _good_index :: Int }
  deriving (QC.Arbitrary, Eq, Ord, Show, Read, Enum, ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Generic)
newtype B  = B { _bid_index :: Int }
  deriving (QC.Arbitrary, Eq, Ord, Show, Read, Enum, ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, FromField, Generic)

instance Default G where def = G 1
instance Default B where def = B 1


-- | An identifying name for a bidder.  This must be unique.
newtype BidderName = BidderName { _BidderName :: T.Text }
  deriving (FromField, ToField, FromJSON, FromJSONKey, ToJSON, ToJSONKey, Generic, Eq, Ord, Show, Read)

-- | Construct a bidder name for a bidder identified only by their
-- position in a list.
mkBidderName :: Int -> BidderName
mkBidderName i = BidderName (T.pack (show i))

instance QC.Arbitrary BidderName where
  arbitrary = mkBidderName <$> QC.arbitrary


arbitraryUnits :: Int -> Int -> QC.Gen Units
arbitraryUnits min_units max_units =
  Units . fromIntegral <$> QC.choose (min_units, max_units)


-- | Controls how much debug output is generated by library.
data Verbosity = Silent -- ^ No extra output
               | Debug  -- ^ Very chatty, for debugging
  deriving (Bounded, Enum, Eq, Ord, Generic, Show)

instance Default Verbosity where
  def = Silent

instance FromJSON Verbosity
  where parseJSON = genericParseJSON $ jsonOptions ""

instance ToJSON Verbosity
  where toJSON = genericToJSON $ jsonOptions ""

instance QC.Arbitrary Verbosity where
  arbitrary = QC.arbitraryBoundedEnum

-- | Execute an IO action, if debug output is enabled.
ifDebug :: Verbosity -> IO () -> IO ()
ifDebug v = when (v >= Debug)

-- | Write out a key-value pair, if debug output is enabled.
debugPutStrLn :: Verbosity -> String -> String -> IO ()
debugPutStrLn v k s = ifDebug v (putStrLn k >> putStrLn s)

-- | Write out a key and the result of showing the value, if debug
-- output is enabled.
debugPrint :: Show a => Verbosity -> String -> a -> IO ()
debugPrint v k x = debugPutStrLn v k (show x)