Implementation okay, but throws NoCorrectors (FIXME)

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]
+    shids <- selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
-  assignHandler tid ssh csh shids
+    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
+  (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn
-  assignHandler tid ssh csh [shid]
+  assignHandler tid ssh csh cid [shid]
 
-assignHandler :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html
+-- DEPRECATED assignHandler'
-assignHandler tid ssh csh rawSids = do
+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
+{- TODO: make buttons for each sheet, so that users see which sheet is assigned
-assignHandler' tid ssh csh _rawSids = do
+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
+  (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
-      cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+      -- 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
+    $(widgetFile "corrections-overview")
-    [whamlet|
-      <div>
-          <h2>_{MsgCorrectionSheets}
-          _{MsgCourseParticipants nrParticipants}
-          <table .table .table--striped .table--hover>
-            <tr .table__row .table__row--head>
-              <th .table__th>_{MsgSheet}
-              $if groupsPossible
-                <th .table__th>_{MsgNrSubmittorsTotal}
-              <th .table__th>_{MsgNrSubmissionsTotal}
-              <th .table__th>_{MsgNrSubmissionsNotAssigned}
-              <th .table__th>_{MsgNrSubmissionsNotCorrected}
-              <th .table__th colspan=3>_{MsgCorrectionTime}
-            $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap
-              <tr .table__row>
-                <td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
-                $if groupsPossible
-                  <td .table__td>#{ciSubmittors}
-                <td .table__td>#{ciSubmissions}
-                <td .table__td>#{ciSubmissions - ciAssigned}
-                <td .table__td>#{ciSubmissions - ciCorrected}
-                <td .table__td>#{showDiffDays ciMin}
-                <td .table__td>#{showAvgsDays ciTot ciCorrected}
-                <td .table__td>#{showDiffDays ciMax}
-      <div>
-          <h2>_{MsgCorrectionCorrectors}
-          <table .table .table--striped .table--hover>
-            <tr .table__row .table__row--head>
-              <th .table__th>_{MsgCorrector}
-              <th .table__th>_{MsgNrSubmissionsTotal}
-              <th .table__th>_{MsgNrSubmissionsNotCorrected}
-              <th .table__th colspan=3>_{MsgCorrectionTime}
-              $forall shn <- sheetNames
-                <th .table__th colspan=3>#{shn}
-            $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap
-              <tr .table__row>
-                <td .table__td>^{showCorrector ciCorrector}
-                <td .table__td>#{ciSubmissions}
-                <td .table__td>#{ciSubmissions - ciCorrected}
-                <td .table__td>#{showDiffDays ciMin}
-                <td .table__td>#{showAvgsDays ciTot ciCorrected}
-                <td .table__td>#{showDiffDays ciMax}
-                $forall shn <- sheetNames
-                  $maybe smap <- Map.lookup shn infoMap
-                    $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- Map.lookup ciCorrector smap
-                      <td .table__td>#{ciAssigned}
-                      <td .table__td>#{ciAssigned - ciCorrected}
-                      <td .table__td>#{showAvgsDays ciTot ciCorrected}
-                    $nothing
-                      <td .table__td colspan=3>
-                  $nothing
-                    <td .table__td colspan=3>
-    |]
 
 
 

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
+assignSubmissions sid restriction = planSubmissions sid restriction >>= writeSubmissionPlan
-    newSubmissionData <- planSubmissions sid restriction
+
+-- | 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

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 --

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 --
 -------------------

templates/corrections-overview.hamlet

@@ -0,0 +1,69 @@
+<div>
+  <h2>_{MsgCorrectionSheets}
+  _{MsgCourseParticipants nrParticipants}
+  <table .table .table--striped .table--hover>
+    <tr .table__row .table__row--head>
+      <th .table__th>_{MsgSheet}
+      $if groupsPossible
+        <th .table__th>_{MsgNrSubmittorsTotal}
+      <th .table__th colspan=2>_{MsgNrSubmissionsTotal}
+      <th .table__th colspan=2>_{MsgNrSubmissionsNotAssigned}
+      <th .table__th>_{MsgNrSubmissionsNotCorrected}
+      <th .table__th colspan=3>_{MsgCorrectionTime}
+    $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap
+      <tr .table__row>
+        <td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
+        $if groupsPossible
+          <td .table__td>#{ciSubmittors}
+        $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment
+          <td .table__td>#{ciSubmissions}
+          <td .table__td .alert-success>(+#{show (Set.size splus)})
+          <td .table__td>#{ciSubmissions - ciAssigned}
+          <td .table__td .alert-danger>(#{show (Set.size sfailed)})
+        $nothing
+          <td .table__td colspan=2>#{ciSubmissions}
+          <td .table__td colspan=2>#{ciSubmissions - ciAssigned}
+        <td .table__td>#{ciSubmissions - ciCorrected}
+        <td .table__td>#{showDiffDays ciMin}
+        <td .table__td>#{showAvgsDays ciTot ciCorrected}
+        <td .table__td>#{showDiffDays ciMax}
+<div>
+  <h2>_{MsgCorrectionCorrectors}
+  <table .table .table--striped .table--hover>
+    <tr .table__row .table__row--head>
+      <th .table__th>_{MsgCorrector}
+      <th .table__th>_{MsgNrSubmissionsTotal}
+      <th .table__th>_{MsgNrSubmissionsNotCorrected}
+      <th .table__th colspan=3>_{MsgCorrectionTime}
+      $forall shn <- sheetNames
+        <th .table__th colspan=4>#{shn}
+    $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap
+      <tr .table__row>
+        <td .table__td>^{showCorrector ciCorrector}
+        <td .table__td>#{ciSubmissions}
+        <td .table__td>#{ciSubmissions - ciCorrected}
+        <td .table__td>#{showDiffDays ciMin}
+        <td .table__td>#{showAvgsDays ciTot ciCorrected}
+        <td .table__td>#{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
+                  <td .table__td>#{ciAssigned}
+                  <td .table__td .alert-success>(+#{nrNew})
+                  <td .table__td>#{ciAssigned - ciCorrected}
+                  <td .table__td>#{showAvgsDays ciTot ciCorrected}
+                $nothing
+                  <td .table__td colspan=2>#{ciAssigned}
+                  <td .table__td>#{ciAssigned - ciCorrected}
+                  <td .table__td>#{showAvgsDays ciTot ciCorrected}
+              $nothing
+                <td .table__td colspan=2>#{ciAssigned}
+                <td .table__td>#{ciAssigned - ciCorrected}
+                <td .table__td>#{showAvgsDays ciTot ciCorrected}
+            $nothing
+              <td .table__td colspan=4>
+          $nothing
+            <td .table__td colspan=4>
+  ^{btnWdgt}