{-# OPTIONS_GHC -fno-warn-orphans #-}

{-|
Module: Model.Types.Misc
Description: Additional uncategorized types
-}

module Model.Types.Misc
  ( module Model.Types.Misc
  , Quoting(..)
  ) where

import Import.NoModel
import Model.Types.TH.PathPiece

import Data.Maybe (fromJust)

import qualified Data.Text as Text
import qualified Data.Text.Lens as Text

import qualified Data.ByteString.Lazy as LBS

import Data.Csv (Quoting(..))
import qualified Data.Csv as Csv

import qualified Data.Aeson as JSON

import Database.Persist.Sql (PersistFieldSql(..))

import Utils.Lens.TH

import Web.HttpApiData


data StudyFieldType = FieldPrimary | FieldSecondary
  deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
  deriving anyclass (Universe, Finite)

derivePersistField "StudyFieldType"
nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1
pathPieceJSON ''StudyFieldType
pathPieceJSONKey ''StudyFieldType



data Theme
  = ThemeDefault
  | ThemeLavender
  | ThemeNeutralBlue
  | ThemeAberdeenReds
  | ThemeMossGreen
  | ThemeSkyLove
  deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Theme"
  } ''Theme

instance Universe Theme
instance Finite Theme

nullaryPathPiece ''Theme $ camelToPathPiece' 1

$(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user

derivePersistField "Theme"


deriving instance Generic Quoting
deriving instance Ord Quoting
deriving instance Read Quoting
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''Quoting
deriveFinite ''Quoting
nullaryPathPiece ''Quoting $ \q -> if
  | q == "QuoteNone" -> "never"
  | otherwise -> camelToPathPiece' 1 q

data CsvOptions
  = CsvOptions
    { csvFormat    :: CsvFormatOptions
    , csvTimestamp :: Bool
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

data CsvFormatOptions
  = CsvFormatOptions
    { csvDelimiter :: Char
    , csvUseCrLf   :: Bool
    , csvQuoting   :: Csv.Quoting
    , csvEncoding  :: DynEncoding
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

makeLenses_ ''CsvOptions
makeLenses_ ''CsvFormatOptions

instance Default CsvOptions where
  def = CsvOptions
    { csvFormat    = def
    , csvTimestamp = False
    }

instance Default CsvFormatOptions where
  def = csvPreset # CsvPresetRFC

data CsvPreset = CsvPresetRFC
               | CsvPresetExcel
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe CsvPreset
instance Finite CsvPreset

csvPreset :: Prism' CsvFormatOptions CsvPreset
csvPreset = prism' fromPreset toPreset
  where
    fromPreset :: CsvPreset -> CsvFormatOptions
    fromPreset CsvPresetRFC   = CsvFormatOptions
      { csvDelimiter = ','
      , csvUseCrLf   = True
      , csvQuoting   = QuoteMinimal
      , csvEncoding  = "UTF8"
      }
    fromPreset CsvPresetExcel = CsvFormatOptions
      { csvDelimiter = ';'
      , csvUseCrLf   = True
      , csvQuoting   = QuoteAll
      , csvEncoding  = "CP1252"
      }

    toPreset :: CsvFormatOptions -> Maybe CsvPreset
    toPreset opts = case filter (\p -> fromPreset p == opts) universeF of
      [p]    -> Just p
      _other -> Nothing

_CsvEncodeOptions :: Iso' CsvFormatOptions Csv.EncodeOptions
_CsvEncodeOptions = iso toEncode fromEncode
  where
    toEncode CsvFormatOptions{..} = Csv.defaultEncodeOptions
      { Csv.encDelimiter     = fromIntegral $ fromEnum csvDelimiter
      , Csv.encUseCrLf       = csvUseCrLf
      , Csv.encQuoting       = csvQuoting
      , Csv.encIncludeHeader = True
      }
    fromEncode encOpts = def
      { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts
      , csvUseCrLf   = Csv.encUseCrLf encOpts
      , csvQuoting   = Csv.encQuoting encOpts
      }

instance ToJSON CsvOptions where
  toJSON CsvOptions{..} = JSON.object
    [ "format"    JSON..= csvFormat
    , "timestamp" JSON..= csvTimestamp
    ]

instance FromJSON CsvOptions where
  parseJSON = JSON.withObject "CsvOptions" $ \o -> do
    csvFormat    <- o JSON..:? "format" JSON..!= csvFormat def
    csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def
    return CsvOptions{..}

instance ToJSON CsvFormatOptions where
  toJSON CsvFormatOptions{..} = JSON.object
    [ "delimiter" JSON..= fromEnum csvDelimiter
    , "use-cr-lf" JSON..= csvUseCrLf
    , "quoting"   JSON..= csvQuoting
    , "encoding"  JSON..= csvEncoding
    ]
instance FromJSON CsvFormatOptions where
  parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do
    csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def
    csvUseCrLf   <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf   def
    csvQuoting   <- o JSON..:? "quoting"   JSON..!= csvQuoting   def
    csvEncoding  <- o JSON..:? "encoding"   JSON..!= csvEncoding   def
    return CsvFormatOptions{..}

derivePersistFieldJSON ''CsvOptions

nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2

instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where
  toMailPart (CsvRendered{..}, encOpts) = do
    _partType .= decodeUtf8 typeCsv'
    _partEncoding .= QuotedPrintableText
    _partContent .= PartContent (recode' $ Csv.encodeByNameWith (encOpts ^. _csvFormat . _CsvEncodeOptions) csvRenderedHeader csvRenderedData)
    where
      recode' :: LBS.ByteString -> LBS.ByteString
      recode'
        | enc == "UTF8"
        = id
        | otherwise
        = encodeLazyByteString enc . decodeLazyByteString UTF8
        where enc = encOpts ^. _csvFormat . _csvEncoding

instance YesodMail site => ToMailPart site CsvRendered where
  toMailPart = toMailPart . (, def :: CsvOptions)


data FavouriteReason
  = FavouriteVisited
  | FavouriteParticipant
  | FavouriteManual
  | FavouriteCurrent
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe FavouriteReason
instance Finite FavouriteReason
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''FavouriteReason
derivePersistFieldJSON ''FavouriteReason


data Sex
  = SexNotKnown
  | SexMale
  | SexFemale
  | SexNotApplicable
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe Sex
instance Finite Sex
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''Sex
nullaryPathPiece ''Sex $ camelToPathPiece' 1

iso5218 :: forall n. Integral n => Prism' n Sex
iso5218 = prism' sexToWord sexFromWord
  where
    sexToWord :: Sex -> n
    sexToWord = \case
      SexNotKnown      -> 0
      SexMale          -> 1
      SexFemale        -> 2
      SexNotApplicable -> 9
    sexFromWord :: n -> Maybe Sex
    sexFromWord = \case
      0 -> Just SexNotKnown
      1 -> Just SexMale
      2 -> Just SexFemale
      9 -> Just SexNotApplicable
      _ -> Nothing

instance PersistField Sex where
  toPersistValue = PersistInt64 . review iso5218
  fromPersistValue (PersistInt64 n)
    | Just s <- n ^? iso5218
    = Right s
  fromPersistValue (PersistDouble (toRational -> n))
    | fromInteger (round n) == n
    , Just s <- (round n :: Integer) ^? iso5218
    = Right s
  fromPersistValue (PersistRational n)
    | fromInteger (round n) == n
    , Just s <- (round n :: Integer) ^? iso5218
    = Right s
  fromPersistValue x = Left $ "Could not convert “" <> tshow x <> "” to Sex"

instance PersistFieldSql Sex where
  sqlType _ = SqlNumeric 1 0

instance Csv.ToField Sex where
  toField = Csv.toField . toPathPiece
instance Csv.FromField Sex where
  parseField = maybe (fail "Could not parse Field of type Sex") return . fromPathPiece <=< Csv.parseField


data TokenBucketIdent = TokenBucketInjectFiles | TokenBucketInjectFilesCount
                      | TokenBucketPruneFiles
                      | TokenBucketRechunkFiles
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite, Hashable)

nullaryPathPiece ''TokenBucketIdent $ camelToPathPiece' 2
pathPieceJSON ''TokenBucketIdent
pathPieceJSONKey ''TokenBucketIdent
derivePersistFieldPathPiece ''TokenBucketIdent

instance ToHttpApiData TokenBucketIdent where
  toUrlPiece = toPathPiece
instance FromHttpApiData TokenBucketIdent where
  parseUrlPiece = maybe (Left "Could not parse TokenBucketIdent") Right . fromPathPiece
