{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-|
Module: Model.Types.Exam
Description: Types for modeling Exams
-}
module Model.Types.Exam
  ( module Model.Types.Exam
  ) where

import Import.NoModel
import Model.Types.Common

import qualified Data.Text as Text

import Control.Lens hiding (universe)
import Utils.Lens.TH

import qualified Data.Csv as Csv
  

data ExamResult' res = ExamAttended { examResult :: res }
                     | ExamNoShow
                     | ExamVoided
  deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable)
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , fieldLabelModifier = camelToPathPiece' 1
  , omitNothingFields = True
  , sumEncoding = TaggedObject "status" "result"
  } ''ExamResult'
derivePersistFieldJSON ''ExamResult'

makeLenses_ ''ExamResult'
makePrisms ''ExamResult'

instance PathPiece res => PathPiece (ExamResult' res) where
  toPathPiece ExamAttended{..} = toPathPiece examResult
  toPathPiece ExamNoShow       = "no-show"
  toPathPiece ExamVoided       = "voided"

  fromPathPiece t
    | t == "no-show" = Just ExamNoShow
    | t == "voided"  = Just ExamVoided
    | Just examResult <- fromPathPiece t
    = Just ExamAttended{..}
    | otherwise = Nothing

instance Applicative ExamResult' where
  pure = ExamAttended
  ExamAttended f <*> ExamAttended x = ExamAttended $ f x
  ExamAttended _ <*> ExamNoShow     = ExamNoShow
  ExamAttended _ <*> ExamVoided     = ExamVoided
  ExamNoShow     <*> _              = ExamNoShow
  ExamVoided     <*> _              = ExamVoided

instance Semigroup res => Semigroup (ExamResult' res) where
  ExamAttended r <> ExamAttended r' = ExamAttended $ r <> r'
  ExamVoided     <> _               = ExamVoided
  _              <> ExamVoided      = ExamVoided
  _              <> _               = ExamNoShow

instance Monoid res => Monoid (ExamResult' res) where
  mempty = ExamAttended mempty
  ExamAttended r `mappend` ExamAttended r' = ExamAttended $ r `mappend` r'
  ExamVoided     `mappend` _               = ExamVoided
  _              `mappend` ExamVoided      = ExamVoided
  _              `mappend` _               = ExamNoShow

instance Csv.ToField res => Csv.ToField (ExamResult' res) where
  toField ExamVoided = "voided"
  toField ExamNoShow = "no-show"
  toField ExamAttended{..} = Csv.toField examResult

instance Csv.FromField res => Csv.FromField (ExamResult' res) where
  parseField "voided"  = pure ExamVoided
  parseField "no-show" = pure ExamNoShow
  parseField x = ExamAttended <$> Csv.parseField x

instance Universe res => Universe (ExamResult' res) where
  universe = concat
    [ pure ExamVoided
    , pure ExamNoShow
    , ExamAttended <$> universe
    ]
instance Finite res => Finite (ExamResult' res)


data ExamBonusRule = ExamNoBonus
                   | ExamBonusPoints
                     { bonusMaxPoints :: Points
                     , bonusOnlyPassed :: Bool
                     }
  deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , fieldLabelModifier = camelToPathPiece' 1
  , sumEncoding = TaggedObject "rule" "settings"
  } ''ExamBonusRule
derivePersistFieldJSON ''ExamBonusRule

data ExamOccurrenceRule = ExamRoomManual
                        | ExamRoomSurname
                        | ExamRoomMatriculation
                        | ExamRoomRandom
  deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  , fieldLabelModifier = camelToPathPiece' 1
  , sumEncoding = TaggedObject "rule" "settings"
  } ''ExamOccurrenceRule
derivePersistFieldJSON ''ExamOccurrenceRule

data ExamGrade
  = Grade50
  | Grade40
  | Grade37
  | Grade33
  | Grade30
  | Grade27
  | Grade23
  | Grade20
  | Grade17
  | Grade13
  | Grade10
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ExamGrade
instance Finite ExamGrade

numberGrade :: Prism' Rational ExamGrade
numberGrade = prism toNumberGrade fromNumberGrade
  where
    toNumberGrade = \case
      Grade50 -> 5.0
      Grade40 -> 4.0
      Grade37 -> 3.7
      Grade33 -> 3.3
      Grade30 -> 3.0
      Grade27 -> 2.7
      Grade23 -> 2.3
      Grade20 -> 2.0
      Grade17 -> 1.7
      Grade13 -> 1.3
      Grade10 -> 1.0
    fromNumberGrade = \case
      5.0 -> Right Grade50
      4.0 -> Right Grade40
      3.7 -> Right Grade37
      3.3 -> Right Grade33
      3.0 -> Right Grade30
      2.7 -> Right Grade27
      2.3 -> Right Grade23
      2.0 -> Right Grade20
      1.7 -> Right Grade17
      1.3 -> Right Grade13
      1.0 -> Right Grade10
      n   -> Left  n

instance PathPiece ExamGrade where
  toPathPiece = tshow . (fromRational :: Rational -> Deci) . review numberGrade
  fromPathPiece = finiteFromPathPiece

pathPieceJSON ''ExamGrade
pathPieceJSONKey ''ExamGrade

instance Csv.ToField ExamGrade where
  toField = Csv.toField . toPathPiece
instance Csv.FromField ExamGrade where
  parseField x = (parse =<< Csv.parseField x) <|> (parse . Text.replace "," "." =<< Csv.parseField x) -- Ugh.
    where parse = maybe (fail "Could not decode PathPiece") return . fromPathPiece

data ExamGradingRule
  = ExamGradingManual
  | ExamGradingKey
    { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4.7@, @n2 <= p < n3 -> p ~ 4.3@, ..., @n11 <= p -> p ~ 1.0@
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  , fieldLabelModifier = camelToPathPiece' 2
  , sumEncoding = TaggedObject "rule" "settings"
  } ''ExamGradingRule
derivePersistFieldJSON ''ExamGradingRule


newtype ExamPassed = ExamPassed { examPassed :: Bool }
  deriving (Read, Show, Generic, Typeable)
  deriving newtype (Eq, Ord, Enum, Bounded)

deriveFinite ''ExamPassed
finitePathPiece ''ExamPassed ["failed", "passed"]
makeWrapped ''ExamPassed
pathPieceCsv ''ExamPassed
pathPieceJSON ''ExamPassed
pathPieceJSONKey ''ExamPassed

passingGrade :: Iso' ExamGrade ExamPassed
-- ^ Improper isomorphism; maps @ExamPassed True@ to `Grade10`
passingGrade = iso (ExamPassed . (>= Grade40)) (bool Grade50 Grade10 . examPassed)
  

type ExamResultPoints = ExamResult' Points
type ExamResultGrade  = ExamResult' ExamGrade
type ExamResultPassed = ExamResult' ExamPassed

instance Csv.ToField (Either ExamResultPassed ExamResultGrade) where
  toField = either Csv.toField Csv.toField

instance Csv.FromField (Either ExamResultPassed ExamResultGrade) where
  parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint
