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

module Model.Types.Misc
  ( module Model.Types.Misc
  ) 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.Csv as Csv

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

import Web.HttpApiData


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

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)
  deriving anyclass (Universe, Finite, NFData)

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

nullaryPathPiece ''Theme $ camelToPathPiece' 1

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

derivePersistField "Theme"


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

makePrisms ''FavouriteReason


data Sex
  = SexNotKnown
  | SexMale
  | SexFemale
  | SexNotApplicable
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite, NFData)
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, NFData)

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
