From 508ed2ecd94bd42679976de96deb274369ab65d8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 17 Aug 2018 16:57:57 +0200 Subject: [PATCH] More sophisticated submission distribution Fixes #77 --- db.hs | 4 +- messages/uniworx/de.msg | 5 ++ models | 1 + package.yaml | 1 + src/Foundation.hs | 15 ++++ src/Handler/Sheet.hs | 34 ++++---- src/Handler/Utils/Form.hs | 12 +++ src/Handler/Utils/Submission.hs | 139 +++++++++++++++++++++++++------- src/Model/Types.hs | 17 ++++ src/Utils.hs | 5 +- 10 files changed, 185 insertions(+), 48 deletions(-) diff --git a/db.hs b/db.hs index 54f0466f4..5cac10dfa 100755 --- a/db.hs +++ b/db.hs @@ -267,8 +267,8 @@ fillDb = do , sheetSolutionFrom = Nothing } void . insert $ SheetEdit jost now sh1 - void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) - void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) + void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal + void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal h102 <- insertFile "H10-2.hs" h103 <- insertFile "H10-3.hs" pdf10 <- insertFile "ProMo_Uebung10.pdf" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2f7bda32d..202bde31c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -160,6 +160,7 @@ SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetN CountTutProp: Tutorien zählen gegen Proportion Corrector: Korrektor Correctors: Korrektoren +CorState: Status CorByTut: Nach Tutorium CorProportion: Anteil DeleteRow: Zeile entfernen @@ -264,3 +265,7 @@ SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe LDAPLoginTitle: Campus-Login DummyLoginTitle: Development-Login + +CorrectorNormal: Normal +CorrectorMissing: Abwesend +CorrectorExcused: Entschuldigt \ No newline at end of file diff --git a/models b/models index d146f2f5b..a0e82edcd 100644 --- a/models +++ b/models @@ -115,6 +115,7 @@ SheetCorrector user UserId sheet SheetId load Load + state CorrectorState default='Normal' UniqueSheetCorrector user sheet deriving Show Eq Ord SheetFile diff --git a/package.yaml b/package.yaml index 5cecac14d..b6d579e8d 100644 --- a/package.yaml +++ b/package.yaml @@ -90,6 +90,7 @@ dependencies: - connection - universe - universe-base +- random-shuffle # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Foundation.hs b/src/Foundation.hs index e94b8950e..a17a74f1d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -196,6 +196,13 @@ instance RenderMessage UniWorX SheetFileType where SheetMarking -> renderMessage' MsgSheetMarking where renderMessage' = renderMessage foundation ls +instance RenderMessage UniWorX CorrectorState where + renderMessage foundation ls = \case + CorrectorNormal -> renderMessage' MsgCorrectorNormal + CorrectorMissing -> renderMessage' MsgCorrectorMissing + CorrectorExcused -> renderMessage' MsgCorrectorExcused + where renderMessage' = renderMessage foundation ls + instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) @@ -903,6 +910,14 @@ pageActions (CSheetR tid csh shn SShowR) = , menuItemAccessCallback' = return True } ] +pageActions (CSheetR tid csh shn SSubsR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Korrektoren" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SCorrR + , menuItemAccessCallback' = return True + } + ] pageActions (CSubmissionR tid csh shn cid SubShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrektur" diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c27ee142a..1335a25d0 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -502,11 +502,11 @@ insertSheetFile' sid ftype fs = do data CorrectorForm = CorrectorForm { cfUserId :: UserId , cfUserName :: Text - , cfResult :: FormResult Load - , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX + , cfResult :: FormResult (CorrectorState, Load) + , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX } -type Loads = Map UserId Load +type Loads = Map UserId (CorrectorState, Load) defaultLoads :: SheetId -> DB Loads -- ^ Generate `Loads` in such a way that minimal editing is required @@ -526,10 +526,10 @@ defaultLoads shid = do E.orderBy [E.desc creationTime] - return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad) + return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where - toMap :: [(E.Value UserId, E.Value Load)] -> Loads - toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load + toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads + toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load) correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX]) @@ -544,19 +544,19 @@ correctorForm shid = do formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) let currentLoads :: DB Loads - currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] + currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads - loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if + loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if | Map.null currentLoads' , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted) - | otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads' + | otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads' deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads') let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions) didDelete = any (flip Set.member deletions) formCIDs - (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads' + (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads' let tutorField :: Field Handler [UserEmail] tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField @@ -586,7 +586,7 @@ correctorForm shid = do case mUid of Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email) Just uid - | not (Map.member uid loads') -> return $ Map.insert uid mempty loads'' + | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads'' | otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email) FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs _ -> return loads'' @@ -598,8 +598,8 @@ correctorForm shid = do return $ (user E.^. UserId, user E.^. UserDisplayName) let - constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm - constructFields (uid, uname, Load{..}) = do + constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm + constructFields (uid, uname, (state, Load{..})) = do cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser let fs name = "" @@ -607,12 +607,13 @@ correctorForm shid = do } rationalField = convertField toRational fromRational doubleField + (stateRes, cfViewState) <- mreq (selectField $ optionsFinite id) (fs "state") (Just state) (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial) (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion) (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False) let - cfResult :: FormResult Load - cfResult = Load <$> tutRes' <*> propRes + cfResult :: FormResult (CorrectorState, Load) + cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes) tutRes' | FormSuccess True <- byTutRes = Just <$> countTutRes | otherwise = Nothing <$ byTutRes @@ -629,6 +630,7 @@ correctorForm shid = do let corrColonnade = mconcat [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName + , headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel @@ -637,7 +639,7 @@ correctorForm shid = do | FormSuccess (Just es) <- addTutRes , not $ null es = FormMissing | didDelete = FormMissing - | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult + | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult) | CorrectorForm{..} <- corrData ] idField CorrectorForm{..} = do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0d5e5e9f8..4ae07b06f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -377,6 +377,18 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs +optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a ) + => (a -> msg) -> m (OptionList a) +optionsFinite toMsg = do + mr <- getMessageRender + let + mkOption a = Option + { optionDisplay = mr $ toMsg a + , optionInternalValue = a + , optionExternalValue = toPathPiece a + } + return . mkOptionList $ mkOption <$> universeF + mforced :: (site ~ HandlerSite m, MonadHandler m) => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site) mforced Field{..} FieldSettings{..} val = do diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 097a505d8..2e866c46f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -25,6 +25,7 @@ module Handler.Utils.Submission ) where import Import hiding ((.=), joinPath) +import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Control.Lens @@ -32,9 +33,10 @@ import Control.Lens.Extras (is) import Utils.Lens import Control.Monad.State hiding (forM_, mapM_,foldM) -import Control.Monad.Writer (MonadWriter(..)) +import Control.Monad.Writer (MonadWriter(..), execWriterT) import Control.Monad.RWS.Lazy (RWST) import qualified Control.Monad.Random as Rand +import qualified System.Random.Shuffle as Rand (shuffleM) import Data.Maybe @@ -45,11 +47,12 @@ import Data.Map (Map, (!?)) import qualified Data.Map as Map import qualified Data.Text as Text +import Data.Ratio import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Data.Monoid (Monoid, Any(..)) +import Data.Monoid (Monoid, Any(..), Sum(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Handler.Utils.Rating hiding (extractRatings) @@ -84,46 +87,126 @@ assignSubmissions :: SheetId -- ^ Sheet do distribute to correction , Set SubmissionId -- ^ unassigend submissions (no tutors by load) ) assignSubmissions sid restriction = do - correctors <- selectList [SheetCorrectorSheet ==. sid] [] - let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto - let corrsProp = filter hasPositiveLoad correctors - let countsToLoad' :: UserId -> Bool - countsToLoad' uid = -- refactor by simply using Map.(!) - fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $ - Map.lookup uid loadMap - loadMap :: Map UserId Bool - loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup] + Sheet{..} <- getJust sid + correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] [] + let + byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ] + corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto + corrsProp = filter hasPositiveLoad correctors + countsToLoad' :: UserId -> Bool + countsToLoad' uid = Map.findWithDefault True uid loadMap + loadMap :: Map UserId Bool + loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial] - subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> do + currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor) -> do let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial) E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser) - E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup)) + E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial)) return $ tutorial E.^. TutorialTutor - E.on $ user E.?. UserId `E.in_` E.justList tutors + E.on $ tutor E.?. UserId `E.in_` E.justList tutors E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction) - E.orderBy [E.rand] -- randomize for fair tutor distribution - return (submission E.^. SubmissionId, user) -- , listToMaybe tutors) + return (submission E.^. SubmissionId, tutor) - queue <- liftIO . Rand.evalRandIO . sequence . repeat $ Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp] + let subTutor' :: Map SubmissionId (Set UserId) + subTutor' = Map.fromListWith Set.union $ currentSubs + & mapped._2 %~ maybe Set.empty Set.singleton + & mapped._2 %~ Set.mapMonotonic entityKey + & mapped._1 %~ E.unValue - let subTutor' :: Map SubmissionId (Maybe UserId) - subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs + prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do + E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser) + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial + E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser + E.where_ $ tutorial E.^. TutorialTutor E.==. sheetCorrector E.^. SheetCorrectorUser + E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission) + E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse + E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors) + return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId)) - subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case - (smid, Just tutid) -> do + let + prevSubs' :: Map SheetId (Map UserId (Rational, Integer)) + prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do + (Entity _ sc@SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs + guard $ maybe True (not isByTutorial ||) byTutorial + let proportion + | CorrectorExcused <- sheetCorrectorState = 0 + | otherwise = byProportion + return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder) + + deficit :: Map UserId Integer + deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs' + + toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer + toDeficit assignments = toDeficit' <$> assignments + where + assigned' = getSum $ foldMap (Sum . snd) assignments + props = getSum $ foldMap (Sum . fst) assignments + + toDeficit' (prop, assigned) = let + target = round $ fromInteger assigned' * (prop / props) + in target - assigned + + $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs' + $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit + + let + lcd :: Integer + lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp + wholeProps :: Map UserId Integer + wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ] + detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit + detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps + + $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue + + queue <- liftIO . Rand.evalRandIO . execWriterT $ do + tell . map Just =<< Rand.shuffleM detQueue + forever $ + tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ] + + $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue) + + let + assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m () + assignSubmission countsToLoad smid tutid = do _1 %= Map.insert smid tutid - when (any ((== tutid) . sheetCorrectorUser . entityVal) corrsProp && countsToLoad' tutid) $ + _3 . at tutid %= assertM' (> 0) . maybe (-1) pred + when countsToLoad $ _2 %= List.delete (Just tutid) - (smid, Nothing) -> do - (q:qs) <- use _2 - _2 .= qs - case q of - Just q -> _1 %= Map.insert smid q - Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion + + maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId) + maximumDeficit = do + transposed <- uses _3 invertMap + traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed) + + subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ (Map.toList subTutor') $ \(smid, tuts) -> do + let + restrictTuts + | Set.null tuts = id + | otherwise = flip Map.restrictKeys tuts + byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit + case byDeficit of + Just q' -> do + $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)" + assignSubmission False smid q' + Nothing + | Set.null tuts -> do + q <- preuse $ _2 . _head . _Just + case q of + Just q' -> do + $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)" + assignSubmission True smid q' + Nothing -> return () + | otherwise -> do + q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts + $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)" + assignSubmission (countsToLoad' q) smid q forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index f84c0cde0..14bd4308a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -349,6 +349,23 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime deriving (Eq, Ord, Read, Show, Enum, Bounded) +data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused + deriving (Eq, Ord, Read, Show, Enum, Bounded) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Corrector" + } ''CorrectorState + +instance Universe CorrectorState where universe = universeDef +instance Finite CorrectorState + +instance PathPiece CorrectorState where + toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + fromPathPiece = finiteFromPathPiece + +derivePersistField "CorrectorState" + + -- Type synonyms type SheetName = CI Text diff --git a/src/Utils.hs b/src/Utils.hs index ee0ffee23..67dfbdd18 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -15,9 +15,7 @@ module Utils import ClassyPrelude.Yesod -- import Data.Double.Conversion.Text -- faster implementation for textPercent? -import Data.List (foldl) import Data.Foldable as Fold -import qualified Data.Char as Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -199,6 +197,9 @@ groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l] partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v partMap = Map.fromListWith mappend +invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) +invertMap = groupMap . map swap . Map.toList + ----------- -- Maybe -- -----------