fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Corrector loads shown; BUG preview somehow missing now

Browse Source
This commit is contained in:
Steffen Jost 2019-06-17 09:47:50 +02:00
parent 8201aa84e5
commit d5b094d6b4
3 changed files with 60 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
src/Handler/Corrections.hs
View File

@ -1082,7 +1082,7 @@ assignHandler' tid ssh csh _cid rawSids = do
\acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing \acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing
-- Too much important information for an alert message. Display proper info page instead -- Too much important information for an alert message. Display proper info page instead
let btnForm = wrapForm btnWdgt def let btnForm = wrapForm btnWdgt def
{ formAction = SomeRoute <$> currentRoute -- TODO: should be a modal route { formAction = SomeRoute <$> currentRoute
, formEncoding = btnEnctype , formEncoding = btnEnctype
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
} }
@ -1132,9 +1132,11 @@ assignHandler tid ssh csh cid assignSids = do
E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
return (corrector, user) return (corrector, user)
let correctorMap :: Map UserId (SheetCorrector,User) let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
correctorMap = foldl (\m (Entity _ corr, Entity uid user)-> Map.insert uid (corr,user) m) Map.empty correctors correctorMap = (\f -> foldl f Map.empty correctors) (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
-- TODO: CorrectorMap should contain Map SheetId SheetCorrector let shn = sheetName $ sheets ! sheetCorrectorSheet
in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc
)
submissions <- E.select . E.from $ \submission -> do submissions <- E.select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
@ -1191,18 +1193,33 @@ assignHandler tid ssh csh cid assignSids = do
assignment <- foldM buildA Map.empty assignSids assignment <- foldM buildA Map.empty assignSids
return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
let -- create aggregate maps let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
-- create aggregate maps
sheetMap :: Map SheetName CorrectionInfo sheetMap :: Map SheetName CorrectionInfo
sheetMap = Map.map fold infoMap sheetMap = Map.map fold infoMap
corrMap :: Map (Maybe UserId) CorrectionInfo corrMap :: Map (Maybe UserId) CorrectionInfo
corrMap = Map.unionsWith (<>) $ Map.elems infoMap corrMap = Map.unionsWith (<>) $ Map.elems infoMap
sheetNames = Map.keys infoMap sheetNames = Map.keys infoMap
let -- whamlet convenience functions let -- whamlet convenience functions
showCorrector :: Maybe UserId -> Widget -- avoid nestes hamelt $maybe with duplicated $nothing
showCorrector (Just uid) getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector)
| Just (_,User{..}) <- Map.lookup uid correctorMap getCorrector (Just uid)
= nameEmailWidget userEmail userDisplayName userSurname | Just (User{..},loadMap) <- Map.lookup uid correctorMap
showCorrector _ = [whamlet|_{MsgNoCorrectorAssigned}|] = (nameEmailWidget userEmail userDisplayName userSurname, loadMap)
getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty)
-- avoid nestes hamelt $maybe with duplicated $nothing
getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
getCorrSheetStatus corr shn
| (Just smap) <- Map.lookup shn infoMap
= Map.lookup corr smap
getCorrSheetStatus _ _ = Nothing
-- avoid nestes hamelt $maybe with duplicated $nothing
getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
getCorrNewAssignment corr shn
| (Just (_,cass)) <- Map.lookup shn assignment
= Map.lookup corr cass
getCorrNewAssignment _ _ = Nothing
showDiffDays :: Maybe NominalDiffTime -> Text showDiffDays :: Maybe NominalDiffTime -> Text
showDiffDays = foldMap formatDiffDays showDiffDays = foldMap formatDiffDays
showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text

12
src/Model/Types/Sheet.hs
View File

@ -305,3 +305,15 @@ instance Hashable CorrectorState
nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
derivePersistField "CorrectorState" 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 "

47
templates/corrections-overview.hamlet
View File

@ -36,34 +36,29 @@
<th .table__th>_{MsgNrSubmissionsNotCorrected} <th .table__th>_{MsgNrSubmissionsNotCorrected}
<th .table__th colspan=3>_{MsgCorrectionTime} <th .table__th colspan=3>_{MsgCorrectionTime}
$forall shn <- sheetNames $forall shn <- sheetNames
<th .table__th colspan=4>#{shn} <th .table__th colspan=5>#{shn}
$forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap
<tr .table__row> $with (nameW,loadM) <- getCorrector ciCorrector
<td .table__td>^{showCorrector ciCorrector} <tr .table__row>
<td .table__td>#{ciSubmissions} <td .table__td>^{nameW}
<td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected} <td .table__td>#{ciSubmissions}
<td .table__td>#{showDiffDays ciMin} <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
<td .table__td>#{showAvgsDays ciTot ciCorrected} <td .table__td>#{showDiffDays ciMin}
<td .table__td>#{showDiffDays ciMax} <td .table__td>#{showAvgsDays ciTot ciCorrected}
$forall shn <- sheetNames <td .table__td>#{showDiffDays ciMax}
$maybe smap <- Map.lookup shn infoMap $forall shn <- sheetNames
$maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- Map.lookup ciCorrector smap $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
$maybe (_,cass) <- Map.lookup shn assignment <td .table__td>#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
$maybe nrNew <- Map.lookup ciCorrector cass $nothing
<td .table__td>#{ciAssigned} <td .table__td>
<td .table__td .alert-success>(+#{nrNew}) $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
<td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciAssigned - ciCorrected} $maybe nrNew <- getCorrNewAssignment ciCorrector shn
<td .table__td>#{showAvgsDays ciTot ciCorrected} <td .table__td>#{ciAssigned}
$nothing <td .table__td .alert-success>(+#{nrNew})
<td .table__td colspan=2>#{ciAssigned}
<td .table__td>#{ciAssigned - ciCorrected}
<td .table__td>#{showAvgsDays ciTot ciCorrected}
$nothing $nothing
<td .table__td colspan=2>#{ciAssigned} <td .table__td colspan=2>#{ciAssigned}
<td .table__td>#{ciAssigned - ciCorrected} <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciAssigned - ciCorrected}
<td .table__td>#{showAvgsDays ciTot ciCorrected} <td .table__td>#{showAvgsDays ciTot ciCorrected}
$nothing $nothing
<td .table__td colspan=4> <td .table__td colspan=5>
$nothing
<td .table__td colspan=4>
^{btnWdgt} ^{btnWdgt}