{-# LANGUAGE UndecidableInstances #-}

{-|
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 Generics.Deriving.Monoid (memptydefault, mappenddefault)

import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.MultiSet as MultiSet

import Text.Blaze (Markup)

import Data.Maybe (fromJust)

import qualified Data.Csv as Csv

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson



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

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 ()
    passPts PassAlways                = Just $ Left ()

gradingPassed :: SheetGrading -> Points -> Maybe Bool
gradingPassed PassAlways _ = Just True
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, Ord)

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 exampartid
  = NotGraded
  | Normal        { grading :: SheetGrading }
  | Bonus         { grading :: SheetGrading }
  | Informational { grading :: SheetGrading }
  | ExamPartPoints
    { examPart  :: exampartid
    , weight    :: Rational
    , grading   :: SheetGrading
    }
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic)
  deriving anyclass (NFData)

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

makeLenses_ ''SheetType
makePrisms ''SheetType

data SheetTypeSummary exampartid = SheetTypeSummary
  { normalSummary
  , bonusSummary
  , informationalSummary :: SheetGradeSummary
  , examSummary :: MergeMap exampartid (MultiSet (Rational, SheetGradeSummary))
  , numNotGraded :: Count
  } deriving (Generic, Show, Eq)

instance Ord epid => Monoid (SheetTypeSummary epid) where
  mempty  = memptydefault
  mappend = mappenddefault

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

makeLenses_ ''SheetTypeSummary

sheetTypeSum :: forall epid. Ord epid => SheetType epid -> Maybe Points -> SheetTypeSummary epid
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 }
sheetTypeSum ExamPartPoints{..} mps = (mempty @(SheetTypeSummary epid)) { examSummary = MergeMap . Map.singleton examPart $ MultiSet.singleton (weight, sheetGradeSum grading mps) }

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)
  deriving anyclass (Hashable, NFData, Universe, Finite)
derivePersistField "SheetFileType"
finitePathPiece ''SheetFileType ["file", "hint", "solution", "marking"]
pathPieceJSON ''SheetFileType

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
  , specificFileEmptyOk :: Bool
  , specificFileMaxSize :: Maybe Natural
  } deriving (Show, Read, Eq, Ord, Generic)

instance ToJSON UploadSpecificFile where
  toJSON UploadSpecificFile{..} = Aeson.object
    [ "label"    Aeson..= specificFileLabel
    , "name"     Aeson..= specificFileName
    , "required" Aeson..= specificFileRequired
    , "empty-ok" Aeson..= specificFileEmptyOk
    , "max-size" Aeson..= specificFileMaxSize
    ]
instance FromJSON UploadSpecificFile where
  parseJSON = Aeson.withObject "UploadSpecificFile" $ \o -> do
    specificFileLabel <- o Aeson..: "label"
    specificFileName <- o Aeson..: "name"
    specificFileRequired <- o Aeson..:? "required" Aeson..!= False
    specificFileEmptyOk <- o Aeson..:? "empty-ok" Aeson..!= True
    specificFileMaxSize <- o Aeson..:? "max-size"
    return UploadSpecificFile{..}
derivePersistFieldJSON ''UploadSpecificFile

data UploadMode = NoUpload
                | UploadAny
                  { uploadUnpackZips :: Bool
                  , uploadExtensionRestriction :: Maybe (NonNull (Set Extension))
                  , uploadEmptyOk :: Bool
                  }
                | UploadSpecific
                  { uploadSpecificFiles :: NonNull (Set UploadSpecificFile)
                  }
  deriving (Show, Read, Eq, Ord, Generic)

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

instance ToJSON UploadMode where
  toJSON NoUpload = Aeson.object [ "mode" Aeson..= ("no-upload" :: String) ]
  toJSON UploadAny{..} = Aeson.object $ catMaybes
    [ pure $ "mode" Aeson..= ("upload" :: String)
    , pure $ "unpack-zips" Aeson..= uploadUnpackZips
    , ("extension-restriction" Aeson..=) <$> assertM' (is _Just) uploadExtensionRestriction
    , pure $ "empty-ok" Aeson..= uploadEmptyOk
    ]
  toJSON UploadSpecific{..} = Aeson.object
    [ "mode" Aeson..= ("upload-specific" :: String)
    , "specific-files" Aeson..= uploadSpecificFiles
    ]
instance FromJSON UploadMode where
  parseJSON = Aeson.withObject "UploadMode" $ \o -> do
    mode <- o Aeson..: "mode" :: Aeson.Parser String
    case mode of
      "no-upload" -> return NoUpload
      "upload" -> do
        uploadUnpackZips <- o Aeson..:? "unpack-zips" Aeson..!= True
        uploadExtensionRestriction <- o Aeson..:? "extension-restriction"
        uploadEmptyOk <- o Aeson..:? "empty-ok" Aeson..!= True
        return UploadAny{..}
      "upload-specific" -> do
        uploadSpecificFiles <- o Aeson..: "specific-files"
        return UploadSpecific{..}
      _ -> fail $ "Unrecognised mode for UploadMode, expecting one of (no-upload|upload|upload-specific): “" <> mode <> "”"
derivePersistFieldJSON ''UploadMode

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

finitePathPiece ''UploadModeDescr
  [ "no-upload"
  , "any"
  , "specific"
  ]

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 = SubmissionModeCorrector
                         | SubmissionModeUser
                         | SubmissionModeBoth
                         | SubmissionModeNone
  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)
  deriving anyclass (Universe, Finite, Hashable)

deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Corrector"
  } ''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  | byProportion == 0 = tutorialText
                                                   | otherwise         = 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"

instance Csv.ToField (SheetType epid, Maybe Points) where
  toField (_, Nothing) = mempty
  toField (sType, Just res)
    | Just passed <- flip gradingPassed res =<< preview _grading sType
    = bool "not-passed" "passed" passed
    | has _grading sType, hasn't (_grading . _passingBound) sType
    = Csv.toField res
  toField (_, Just _)
    = "submitted"
