{-|
Module: Model.Types.Sheet
Description: Types for modeling sheets
-}

module Model.Types.Sheet
  ( module Model.Types.Sheet
  ) where

import Import.NoModel
import Model.Types.Common
import Utils.Lens.TH

import Control.Lens
import Control.Lens.Extras (is)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))

import Text.Blaze (Markup)

import Yesod.Core.Dispatch (PathPiece(..))

import Data.Maybe (fromJust)


data SheetGrading
  = Points     { maxPoints :: Points }
  | PassPoints { maxPoints, passingPoints :: Points }
  | PassBinary -- non-zero means passed
  deriving (Eq, Read, Show, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel
  , sumEncoding = TaggedObject "type" "data"
  } ''SheetGrading
derivePersistFieldJSON ''SheetGrading

makeLenses_ ''SheetGrading
makePrisms ''SheetGrading

_passingBound :: Fold SheetGrading (Either () Points)
_passingBound = folding passPts
  where
    passPts :: SheetGrading -> Maybe (Either () Points)
    passPts Points{}                  = Nothing
    passPts PassPoints{passingPoints} = Just $ Right passingPoints
    passPts PassBinary                = Just $ Left ()

gradingPassed :: SheetGrading -> Points -> Maybe Bool
gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
    where pBinary _ = pts /= 0
          pPoints b = pts >= b


data SheetGradeSummary = SheetGradeSummary
  { numSheets       :: Count       -- Total number of sheets, includes all
  , numSheetsPasses :: Count       -- Number of sheets admitting passing FKA: numGradePasses
  , numSheetsPoints :: Count       -- Number of sheets having points     FKA: sumGradePointsd
  , numSheetsPassPoints :: Count   -- Number of sheets where passing is by points
  , sumSheetsPoints :: Sum Points  -- Total of all points in all sheets
  , sumSheetsPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points
  -- Marking dependend
  , numMarked       :: Count       -- Number of already marked sheets
  , numMarkedPasses :: Count       -- Number of already marked sheets with passes
  , numMarkedPoints :: Count       -- Number of already marked sheets with points
  , numMarkedPassPoints :: Count   -- Number of already marked sheets where passing is by points
  , sumMarkedPoints :: Sum Points  -- Achieveable points within marked sheets
  , sumMarkedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points
  --
  , achievedPasses :: Count        -- Achieved passes (within marked sheets)
  , achievedPoints :: Sum Points   -- Achieved points (within marked sheets)
  , achievedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points
  } deriving (Generic, Read, Show, Eq)

instance Monoid SheetGradeSummary where
  mempty  = memptydefault
  mappend = mappenddefault

instance Semigroup SheetGradeSummary where
  (<>) = mappend -- TODO: remove for GHC > 8.4.x

makeLenses_ ''SheetGradeSummary

sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
sheetGradeSum gr Nothing  = mempty
  { numSheets = 1
  , numSheetsPasses     = bool  mempty   1 $ has _passingBound gr
  , numSheetsPoints     = bool  mempty   1 $ has _maxPoints    gr
  , numSheetsPassPoints = bool  mempty   1 $ is  _PassPoints   gr
  , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints
  , sumSheetsPassPoints = maybe mempty Sum . (<* guard (is _PassPoints gr)) $ gr ^? _maxPoints
  }
sheetGradeSum gr (Just p) =
  let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
  in  unmarked
        { numMarked           = numSheets
        , numMarkedPasses     = numSheetsPasses
        , numMarkedPoints     = numSheetsPoints
        , numMarkedPassPoints = numSheetsPassPoints
        , sumMarkedPoints     = sumSheetsPoints
        , sumMarkedPassPoints = sumSheetsPassPoints
        , achievedPasses  = maybe mempty (bool 0 1) (gradingPassed gr p)
        , achievedPoints  = bool mempty (Sum p) $ has _maxPoints gr
        , achievedPassPoints = bool mempty (Sum p) $ is _PassPoints gr
        }


data SheetType
  = NotGraded
  | Normal        { grading :: SheetGrading }
  | Bonus         { grading :: SheetGrading }
  | Informational { grading :: SheetGrading }
  deriving (Eq, Read, Show, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  , fieldLabelModifier = camelToPathPiece
  , sumEncoding = TaggedObject "type" "data"
  } ''SheetType
derivePersistFieldJSON ''SheetType

data SheetTypeSummary = SheetTypeSummary
  { normalSummary
  , bonusSummary
  , informationalSummary :: SheetGradeSummary
  , numNotGraded :: Count
  } deriving (Generic, Read, Show, Eq)

instance Monoid SheetTypeSummary where
  mempty  = memptydefault
  mappend = mappenddefault

instance Semigroup SheetTypeSummary where
  (<>) = mappend -- TODO: remove for GHC > 8.4.x

makeLenses_ ''SheetTypeSummary

sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
sheetTypeSum NotGraded _           = mempty { numNotGraded         = Sum 1 }

data SheetGroup
  = Arbitrary { maxParticipants :: Natural }
  | RegisteredGroups
  | NoGroups
  deriving (Show, Read, Eq, Generic)
deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON ''SheetGroup

makeLenses_ ''SheetGroup

data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
derivePersistField "SheetFileType"

instance Universe SheetFileType
instance Finite SheetFileType

instance PathPiece SheetFileType where
  toPathPiece SheetExercise = "file"
  toPathPiece SheetHint     = "hint"
  toPathPiece SheetSolution = "solution"
  toPathPiece SheetMarking  = "marking"
  fromPathPiece = finiteFromPathPiece

sheetFile2markup :: SheetFileType -> Markup
sheetFile2markup SheetExercise = iconSFTQuestion
sheetFile2markup SheetHint     = iconSFTHint
sheetFile2markup SheetSolution = iconSFTSolution
sheetFile2markup SheetMarking  = iconSFTMarking

-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
-- partitionFileType' = groupMap

partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs


data UploadSpecificFile = UploadSpecificFile
  { specificFileLabel :: Text
  , specificFileName :: FileName
  , specificFileRequired :: Bool
  } deriving (Show, Read, Eq, Ord, Generic)

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  } ''UploadSpecificFile
derivePersistFieldJSON ''UploadSpecificFile

data UploadMode = NoUpload
                | UploadAny
                  { unpackZips :: Bool
                  , extensionRestriction :: Maybe (NonNull (Set Extension))
                  }
                | UploadSpecific
                  { specificFiles :: NonNull (Set UploadSpecificFile)
                  }
  deriving (Show, Read, Eq, Ord, Generic)

defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]

deriveJSON defaultOptions
  { constructorTagModifier = \c -> if
      | c == "UploadAny" -> "upload"
      | otherwise        -> camelToPathPiece c
  , fieldLabelModifier = camelToPathPiece
  , sumEncoding = TaggedObject "mode" "settings"
  , omitNothingFields = True
  }''UploadMode
derivePersistFieldJSON ''UploadMode

data UploadModeDescr = UploadModeNone
                     | UploadModeAny
                     | UploadModeSpecific
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe UploadModeDescr
instance Finite UploadModeDescr

nullaryPathPiece ''UploadModeDescr $ camelToPathPiece' 2

classifyUploadMode :: UploadMode -> UploadModeDescr
classifyUploadMode NoUpload = UploadModeNone
classifyUploadMode UploadAny{} = UploadModeAny
classifyUploadMode UploadSpecific{} = UploadModeSpecific

data SubmissionMode = SubmissionMode
  { submissionModeCorrector :: Bool
  , submissionModeUser :: Maybe UploadMode
  }
  deriving (Show, Read, Eq, Ord, Generic)

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  } ''SubmissionMode
derivePersistFieldJSON ''SubmissionMode

data SubmissionModeDescr = SubmissionModeNone
                         | SubmissionModeCorrector
                         | SubmissionModeUser
                         | SubmissionModeBoth
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe SubmissionModeDescr
instance Finite SubmissionModeDescr

finitePathPiece ''SubmissionModeDescr
  [ "no-submissions"
  , "correctors"
  , "users"
  , "correctors+users"
  ]

classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
classifySubmissionMode (SubmissionMode True  Nothing ) = SubmissionModeCorrector
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth


-- | Specify a corrector's workload
data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
    = Load { byTutorial :: Maybe Bool  -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload
           , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
           }
  deriving (Show, Read, Eq, Ord, Generic)

deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load

instance Hashable Load

instance Semigroup Load where
  (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
    where
      byTut''
        | Nothing <- byTut  = byTut'
        | Nothing <- byTut' = byTut
        | Just a <- byTut
        , Just b <- byTut'  = Just $ a || b

instance Monoid Load where
  mempty = Load Nothing 0
  mappend = (<>)

{- Use (is _ByTutorial) instead of this unneeded definition:
  isByTutorial :: Load -> Bool
  isByTutorial (ByTutorial {}) = True
  isByTutorial _               = False
-}

data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Corrector"
  } ''CorrectorState

instance Universe CorrectorState
instance Finite CorrectorState

instance Hashable CorrectorState

nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)

derivePersistField "CorrectorState"

showCompactCorrectorLoad :: Load -> CorrectorState -> Text
showCompactCorrectorLoad load     CorrectorMissing = "[" <> showCompactCorrectorLoad load CorrectorNormal <> "]"
showCompactCorrectorLoad load     CorrectorExcused = "{" <> showCompactCorrectorLoad load CorrectorNormal <> "}"
showCompactCorrectorLoad Load{..} CorrectorNormal  =        proportionText <> tutorialText
  where
    proportionText = let propDbl :: Double
                         propDbl = fromRational byProportion
                     in  tshow $ roundToDigits 2 propDbl
    tutorialText = case byTutorial of Nothing    -> mempty
                                      Just True  -> " (T)"
                                      Just False -> " +T "
