diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 0e2f70e21..6a9c1b7aa 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1042,19 +1042,21 @@ data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiC getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAssignR = postCAssignR postCAssignR tid ssh csh = do - shids <- runDB $ do + (shids,cid) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] - assignHandler tid ssh csh shids + shids <- selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] + return (shids,cid) + assignHandler tid ssh csh cid shids getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSAssignR = postSAssignR postSAssignR tid ssh csh shn = do - shid <- runDB $ fetchSheetId tid ssh csh shn - assignHandler tid ssh csh [shid] + (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn + assignHandler tid ssh csh cid [shid] -assignHandler :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html -assignHandler tid ssh csh rawSids = do +-- DEPRECATED assignHandler' +assignHandler' :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html +assignHandler' tid ssh csh _cid rawSids = do -- gather data openSubs <- runDB $ (\f -> foldM f Map.empty rawSids) $ \acc sid -> maybeT (return acc) $ do @@ -1094,11 +1096,28 @@ assignHandler tid ssh csh rawSids = do else btnForm -assignHandler' :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html -assignHandler' tid ssh csh _rawSids = do +{- TODO: make buttons for each sheet, so that users see which sheet is assigned +data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Button UniWorX ButtonCorrectionsAssign +-- Are those needed any more? +instance Universe ButtonCorrectionsAssign +instance Finite ButtonCorrectionsAssign +nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id +instance Button UniWorX ButtonCorrectionsAssign where + btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary] +-- use runButtonForm' instead later on +-} + +assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html +assignHandler tid ssh csh cid assignSids = do + -- evaluate form first, since it affects DB action + (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions + -- gather data - (nrParticipants, groupsPossible, infoMap, correctorMap) <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do + -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid] sheetList <- selectList [SheetCourse ==. cid] [Asc SheetName] @@ -1144,7 +1163,19 @@ assignHandler' tid ssh csh _rawSids = do , ciMax = corTime } in Map.insertWith (Map.unionWith (<>)) shnm cinf m - return (nrParticipants, groupsPossible, infoMap, correctorMap) + -- plan or assign unassigned submissions for given sheets + -- assignment :: Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int) + assignment <- fmap Map.fromList $ forM assignSids $ \sid -> do + plan <- planSubmissions sid Nothing + let shn = sheetName $ sheets ! sid + status <- case btnResult of + Nothing -> return (Set.empty, Set.empty) + (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan + return (shn, (status, countMapElems plan)) + + return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) + + let -- create aggregate maps sheetMap :: Map SheetName CorrectionInfo @@ -1167,60 +1198,7 @@ assignHandler' tid ssh csh _rawSids = do headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign siteLayoutMsg headingShort $ do setTitleI headingLong - -- TODO: Move whamlet into separate Widget-File, once completed - [whamlet| -
-

_{MsgCorrectionSheets} - _{MsgCourseParticipants nrParticipants} - - - -
_{MsgSheet} - $if groupsPossible - _{MsgNrSubmittorsTotal} - _{MsgNrSubmissionsTotal} - _{MsgNrSubmissionsNotAssigned} - _{MsgNrSubmissionsNotCorrected} - _{MsgCorrectionTime} - $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap -
^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)} - $if groupsPossible - #{ciSubmittors} - #{ciSubmissions} - #{ciSubmissions - ciAssigned} - #{ciSubmissions - ciCorrected} - #{showDiffDays ciMin} - #{showAvgsDays ciTot ciCorrected} - #{showDiffDays ciMax} -
-

_{MsgCorrectionCorrectors} - - - -
_{MsgCorrector} - _{MsgNrSubmissionsTotal} - _{MsgNrSubmissionsNotCorrected} - _{MsgCorrectionTime} - $forall shn <- sheetNames - #{shn} - $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap -
^{showCorrector ciCorrector} - #{ciSubmissions} - #{ciSubmissions - ciCorrected} - #{showDiffDays ciMin} - #{showAvgsDays ciTot ciCorrected} - #{showDiffDays ciMax} - $forall shn <- sheetNames - $maybe smap <- Map.lookup shn infoMap - $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- Map.lookup ciCorrector smap - #{ciAssigned} - #{ciAssigned - ciCorrected} - #{showAvgsDays ciTot ciCorrected} - $nothing - - $nothing - - |] + $(widgetFile "corrections-overview") diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index dc55df410..61bb7ee53 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -1,6 +1,6 @@ module Handler.Utils.Submission ( AssignSubmissionException(..) - , assignSubmissions + , assignSubmissions, writeSubmissionPlan, planSubmissions , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg , submissionFileSource, submissionFileQuery , submissionMultiArchive @@ -66,8 +66,15 @@ assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> YesodDB UniWorX ( Set SubmissionId , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load -assignSubmissions sid restriction = do - newSubmissionData <- planSubmissions sid restriction +assignSubmissions sid restriction = planSubmissions sid restriction >>= writeSubmissionPlan + +-- | Assigns all submissions according to an already given assignment plan +writeSubmissionPlan :: Map SubmissionId (Maybe UserId) + -- ^ map that assigns submissions to correctors + -> YesodDB UniWorX ( Set SubmissionId + , Set SubmissionId + ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load +writeSubmissionPlan newSubmissionData = do now <- liftIO getCurrentTime execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, mCorrector) -> case mCorrector of Just corrector -> do @@ -78,7 +85,6 @@ assignSubmissions sid restriction = do Nothing -> tell (mempty, Set.singleton subId) - -- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet! planSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider diff --git a/src/Utils.hs b/src/Utils.hs index 22e5b3b91..da5d7f0c4 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -500,6 +500,11 @@ partMap = Map.fromListWith mappend invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList +-- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons) +countMapElems :: (Ord v) => Map k v -> Map v Int +countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList + + --------------- -- Functions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index ec6e12730..69eb65254 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -356,10 +356,11 @@ buttonView btn = do fieldView bField btnId "" mempty (Right btn) False - +-- | generate a form that only shows a finite amount of buttons buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ()) buttonForm = buttonForm' universeF +-- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ()) buttonForm' btns csrf = do (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns "" @@ -370,6 +371,35 @@ buttonForm' btns csrf = do ^{fvInput bView} |]) +-- | buttons-only form complete with widget-generation and evaluation; return type determines buttons shown. +runButtonForm ::(PathPiece ident, Eq ident, RenderMessage site FormMessage, + Button site ButtonSubmit, Button site a, Finite a) + => ident -> HandlerT site IO (WidgetT site IO (), Maybe a) +runButtonForm fid = do + currentRoute <- getCurrentRoute + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid buttonForm + let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute + , formEncoding = btnEnctype + , formSubmit = FormNoSubmit + } + res <- formResultMaybe btnResult (return . Just) + return (btnForm, res) + +-- | like `runButtonForm` but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass. +runButtonForm' ::(PathPiece ident, Eq ident, RenderMessage site FormMessage, + Button site ButtonSubmit, Button site a) + => [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) +runButtonForm' btns fid = do + currentRoute <- getCurrentRoute + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ buttonForm' btns + let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute + , formEncoding = btnEnctype + , formSubmit = FormNoSubmit + } + res <- formResultMaybe btnResult (return . Just) + return (btnForm, res) + + ------------------- -- Custom Fields -- ------------------- diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet new file mode 100644 index 000000000..595b28a80 --- /dev/null +++ b/templates/corrections-overview.hamlet @@ -0,0 +1,69 @@ +
+

_{MsgCorrectionSheets} + _{MsgCourseParticipants nrParticipants} + + + +
_{MsgSheet} + $if groupsPossible + _{MsgNrSubmittorsTotal} + _{MsgNrSubmissionsTotal} + _{MsgNrSubmissionsNotAssigned} + _{MsgNrSubmissionsNotCorrected} + _{MsgCorrectionTime} + $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap +
^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)} + $if groupsPossible + #{ciSubmittors} + $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment + #{ciSubmissions} + (+#{show (Set.size splus)}) + #{ciSubmissions - ciAssigned} + (#{show (Set.size sfailed)}) + $nothing + #{ciSubmissions} + #{ciSubmissions - ciAssigned} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} +
+

_{MsgCorrectionCorrectors} + + + +
_{MsgCorrector} + _{MsgNrSubmissionsTotal} + _{MsgNrSubmissionsNotCorrected} + _{MsgCorrectionTime} + $forall shn <- sheetNames + #{shn} + $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap +
^{showCorrector ciCorrector} + #{ciSubmissions} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} + $forall shn <- sheetNames + $maybe smap <- Map.lookup shn infoMap + $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- Map.lookup ciCorrector smap + $maybe (_,cass) <- Map.lookup shn assignment + $maybe nrNew <- Map.lookup ciCorrector cass + #{ciAssigned} + (+#{nrNew}) + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + #{ciAssigned} + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + #{ciAssigned} + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + + $nothing + + ^{btnWdgt} \ No newline at end of file