Merge branch 'master' into changelog

.vscode/tasks.json

@@ -58,6 +58,11 @@
       "type": "npm",
       "script": "start",
       "problemMatcher": []
+    },
+    {
+      "type": "npm",
+      "script": "frontend:lint",
+      "problemMatcher": []
     }
   ]
 }

CHANGELOG_DE.md

@@ -1,5 +1,10 @@
 # Changelog
 
+### Version 07.06.2019
+
+- Abgaben können bestimmte Dateinamen und Endungen erzwingen
+- Übungsblätter bieten nun Zip-Archive für alle veröffentlichte Dateien, bzw. Dateigruppen an
+
 ### Version 20.05.2019
 
 - Komplett überarbeitete Funktionalität zur automatischen Verteilung von Korrekturen

frontend/src/utils/async-table/async-table.js

@@ -296,20 +296,18 @@ export class AsyncTable {
     return el.getAttribute('href') || el.querySelector('a').getAttribute('href');
   }
 
-  _changePagesizeHandler = (event) => {
+  _changePagesizeHandler = () => {
-    const paginationParamKey = this._asyncTableId + '-pagination';
-    const pagesizeParamKey = this._asyncTableId + '-pagesize';
-    const pageParamKey = this._asyncTableId + '-page';
-
-    const paginationParamEl = this._pagesizeForm.querySelector('[name="' + paginationParamKey + '"]');
     const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href);
-    url.searchParams.set(pagesizeParamKey, event.target.value);
+    const formData = new FormData(this._pagesizeForm);
-    url.searchParams.set(pageParamKey, 0);
 
-    if (paginationParamEl) {
+    for (var k of url.searchParams.keys()) {
-      const encodedValue = encodeURIComponent(paginationParamEl.value);
+      url.searchParams.delete(k);
-      url.searchParams.set(paginationParamKey, encodedValue);
     }
+
+    for (var kv of formData.entries()) {
+      url.searchParams.append(kv[0], kv[1]);
+    }
+
     this._updateTableFrom(url.href);
   }
 

messages/uniworx/de.msg

@@ -394,14 +394,22 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
 CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
 SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
 
+
+CorrectionSheets: Übersicht Korrekturen nach Blättern
+CorrectionCorrectors: Übersicht Korrekturen nach Korrektoren
 AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt
 AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt
 AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
+NrSubmittorsTotal: Abgebende
 NrSubmissionsTotal: Abgaben
 NrSubmissionsUnassigned: Ohne Korrektor
+NoCorrectorAssigned: Ohne Korrektor
 NrCorrectors: Korrektoren
 NrSubmissionsNewlyAssigned: Neu zugeteilt
 NrSubmissionsNotAssigned: Nicht zugeteilt
+NrSubmissionsNotCorrected: Unkorrigiert
+CorrectionTime: Korrekturdauer (Min/Avg/Max)
+AssignSubmissionsRandomWarning: Die Zuteilungsvorschau kann geringfügig von der tatsächlichen Zuteilung abweichen, da die Zuteilung ein randomisierter Prozess ist. Mehrfaches neues Laden dieser Seite vor Betätigung des Zuteilungsknopfes kann dies sichtbar machen.
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
 NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
@@ -829,7 +837,8 @@ MenuCorrectionsUpload: Korrekturen hochladen
 MenuCorrectionsDownload: Offene Abgaben herunterladen
 MenuCorrectionsCreate: Abgaben registrieren
 MenuCorrectionsGrade: Abgaben online korrigieren
-MenuCorrectionsAssign: Abgaben automatisch zuteilen
+MenuCorrectionsAssign: Zuteilung Korrekturen
+MenuCorrectionsAssignSheet name@Text: Zuteilung Korrekturen von #{name}
 MenuAuthPreds: Authorisierungseinstellungen
 MenuTutorialDelete: Tutorium löschen
 MenuTutorialEdit: Tutorium editieren
@@ -971,7 +980,7 @@ TutorialDelete: Löschen
 
 CourseTutorials: Übungen
 
-ParticipantsN n@Int: Teilnehmer
+ParticipantsN n@Int: #{tshow n} Teilnehmer
 TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen?
 TutorialDeleted: Tutorium gelöscht
 
@@ -1007,6 +1016,7 @@ HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden w
 HealthSMTPConnect: SMTP-Server kann erreicht werden
 HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
 
+CourseParticipants n@Int: Derzeit #{tshow n} angemeldete Kursteilnehmer
 CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
 CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
 CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}

models/sheets

@@ -4,7 +4,7 @@ Sheet   -- exercise sheet for a given course
     description     Html Maybe
     type            SheetType        -- Does it count towards overall course grade?
     grouping        SheetGroup       -- May participants submit in groups of certain sizes?
-    markingText     Html Maybe       -- Instructions for correctors, included in marking templates
+    markingText     Html Maybe       -- Instructons for correctors, included in marking templates
     visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
     activeFrom      UTCTime          -- Download of questions and submission is permitted afterwards
     activeTo        UTCTime          -- Submission is only permitted before

src/Foundation.hs

@@ -1427,7 +1427,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CInviteR)   = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
-  breadcrumb (CourseR tid ssh csh CAssignR)   = return ("Zuteilen"   , Just $ CourseR tid ssh csh CCorrectionsR)
+  breadcrumb (CourseR tid ssh csh CAssignR)   = return ("Korrektur"  , Just $ CourseR tid ssh csh CCorrectionsR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu",         Just $ CourseR tid ssh csh SheetListR)
   breadcrumb (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR)
@@ -1744,7 +1744,7 @@ pageActions  InstanceR = [
   ]
 pageActions (HelpR) = [
     -- MenuItem
-    --   { menuItemType = PageActionPrime
+    --   { menuItemType  = PageActionPrime
     --   , menuItemLabel = MsgInfoLecturerTitle
     --   , menuItemIcon  = Nothing
     --   , menuItemRoute = SomeRoute InfoLecturerR
@@ -1754,7 +1754,7 @@ pageActions (HelpR) = [
   ]
 pageActions (ProfileR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuProfileData
       , menuItemIcon  = Just "book"
       , menuItemRoute = SomeRoute ProfileDataR
@@ -1762,7 +1762,7 @@ pageActions (ProfileR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuAuthPreds
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute AuthPredsR
@@ -1772,7 +1772,7 @@ pageActions (ProfileR) =
   ]
 pageActions TermShowR =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuTermCreate
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute TermEditR
@@ -1782,7 +1782,7 @@ pageActions TermShowR =
   ]
 pageActions (TermCourseListR tid) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCourseNew
       , menuItemIcon  = Just "book"
       , menuItemRoute = SomeRoute CourseNewR
@@ -1790,7 +1790,7 @@ pageActions (TermCourseListR tid) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuTermEdit
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ TermEditExistR tid
@@ -1810,7 +1810,7 @@ pageActions (TermSchoolCourseListR _tid _ssh) =
   ]
 pageActions (CourseListR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCourseNew
       , menuItemIcon  = Just "book"
       , menuItemRoute = SomeRoute CourseNewR
@@ -1820,7 +1820,7 @@ pageActions (CourseListR) =
   ]
 pageActions (CourseNewR) = [
     MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgInfoLecturerTitle
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute InfoLecturerR
@@ -1849,7 +1849,7 @@ pageActions (CourseR tid ssh csh CShowR) =
           in runDB $ lecturerAccess `or2M` existsVisible
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSheetList
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
@@ -1877,7 +1877,7 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuCourseMembers
       , menuItemIcon  = Just "user-graduate"
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR
@@ -1885,7 +1885,7 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuCourseCommunication
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR
@@ -1893,7 +1893,7 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuCourseEdit
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR
@@ -1901,7 +1901,7 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuCourseClone
       , menuItemIcon  = Just "copy"
       , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
@@ -1909,9 +1909,9 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuCourseDelete
-      , menuItemIcon = Just "trash"
+      , menuItemIcon  = Just "trash"
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
@@ -1919,17 +1919,17 @@ pageActions (CourseR tid ssh csh CShowR) =
   ]
 pageActions (CourseR tid ssh csh CCorrectionsR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsAssign
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
-      , menuItemModal = True
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
 pageActions (CourseR tid ssh csh SheetListR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSheetCurrent
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR
@@ -1939,7 +1939,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
           return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSheetOldUnassigned
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR
@@ -1949,25 +1949,25 @@ pageActions (CourseR tid ssh csh SheetListR) =
           return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSubmissions
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsAssign
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
-      , menuItemModal = True
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsOwn
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term"  , termToText $ unTermKey tid)
                                                  , ("corrections-school", CI.original $ unSchoolKey ssh)
                                                  , ("corrections-course", CI.original csh)
@@ -1988,7 +1988,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
               return ok
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSheetNew
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR
@@ -2082,7 +2082,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) =
   ]
 pageActions (CSheetR tid ssh csh shn SShowR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSubmissionNew
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
@@ -2094,7 +2094,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
           return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSubmissionOwn
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR
@@ -2118,49 +2118,49 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectors
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSubmissions
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
    , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsAssign
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
-      , menuItemModal = True
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSheetEdit
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuSheetClone
-      , menuItemIcon = Just "copy"
+      , menuItemIcon  = Just "copy"
       , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuSheetDelete
-      , menuItemIcon = Just "trash"
+      , menuItemIcon  = Just "trash"
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
@@ -2168,7 +2168,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
   ]
 pageActions (CSheetR tid ssh csh shn SSubsR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSubmissionNew
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
@@ -2176,25 +2176,25 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectors
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
  , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsAssign
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
-      , menuItemModal = True
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
 pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuCorrection
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
@@ -2202,7 +2202,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgCorrectorAssignTitle
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR
@@ -2210,7 +2210,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuSubmissionDelete
       , menuItemIcon  = Just "trash"
       , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
@@ -2220,7 +2220,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
   ]
 pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
   [ MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuSubmissionDelete
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
@@ -2230,17 +2230,17 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
   ]
 pageActions (CSheetR tid ssh csh shn SCorrR) =
   [ MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuSubmissions
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionSecondary
+      { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuSheetEdit
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
       , menuItemModal = False
       , menuItemAccessCallback' = return True

src/Handler/Corrections.hs

@@ -5,6 +5,7 @@ import Import
 
 import Jobs
 import Handler.Utils
+import Handler.Utils.Corrections
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
 import Handler.Utils.SheetType
@@ -13,11 +14,11 @@ import Handler.Utils.Delete
 
 import Utils.Lens
 
-import Data.List (nub)
+import Data.List as List (nub, foldl, foldr)
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map, (!))
+import Data.Map.Strict (Map, (!))
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
@@ -250,7 +251,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
           E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
           return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
-          submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
+          submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
         dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
   dbTable psValidator DBTable
     { dbtSQLQuery
@@ -1035,25 +1036,27 @@ embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
 instance Button UniWorX ButtonSubmissionsAssign where
   btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
 
--- | Gather info about corrector assignment per sheet
+-- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet
 data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
 
 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', delete me soonish
-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
@@ -1079,7 +1082,7 @@ assignHandler tid ssh csh rawSids = do
         \acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing
       -- Too much important information for an alert message. Display proper info page instead
   let btnForm = wrapForm btnWdgt def
-                { formAction = SomeRoute <$> currentRoute -- TODO: should be a modal route
+                { formAction = SomeRoute <$> currentRoute
                 , formEncoding = btnEnctype
                 , formSubmit = FormNoSubmit
                 }
@@ -1092,3 +1095,150 @@ assignHandler tid ssh csh rawSids = do
       then linkBack  -- TODO: convenience link might be unnecessary: either via breadcrumb or closing model. Remove, if modal works fine. Otherwise change to PrimaryAction?
       else btnForm
 
+
+{- 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, assignment) <- runDB $ do
+      -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+      nrParticipants <- count [CourseParticipantCourse ==. cid]
+
+      sheetList <- selectList [SheetCourse ==. cid] [Asc SheetName]
+      let sheets = entities2map sheetList
+          sheetIds = Map.keys sheets
+          groupsPossible :: Bool
+          groupsPossible =
+            let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
+            in  List.foldr foldFun False sheetList
+
+      -- plan or assign unassigned submissions for given sheets
+      let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int))
+          buildA acc sid = maybeT (return acc) $ do
+            let shn = sheetName $ sheets ! sid
+            -- is sheet closed?
+            guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR  -- we must check, whether the submission is already closed and thus assignable
+            -- has at least one submisison?
+            [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> do
+              E.where_ $ submission E.^. SubmissionSheet    E.==. E.val sid
+              E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy
+            guard hasSubmission
+            -- has at least one active corrector?
+            [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do
+              E.where_ $ corrector E.^. SheetCorrectorSheet E.==. E.val sid
+              E.where_ $ corrector E.^. SheetCorrectorState E.==. E.val CorrectorNormal
+              -- E.where_ $ corrector E.^. SheetCorrectorLoad  E./=. E.val (Load {byTutorial = Nothing, byProportion = 0})
+            guard hasCorrector
+            -- TODO: Refactor guards above! We already have these informations, but forcing the maps inside the DB acces might not be a good idea
+            -- TODO: Maybe refactor planSubmissions instead to not throw exceptions, but signal "ok" or "not possible" instead!
+            plan <- lift $ planSubmissions sid Nothing
+            status <- lift $ case btnResult of
+              Nothing -> return (Set.empty, Set.empty)
+              (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan -- TODO: this comes to late!!
+            return $ Map.insert shn (status, countMapElems plan) acc
+      assignment <- foldM buildA Map.empty assignSids
+
+      correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
+          E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+          E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
+          return (corrector, user)
+      let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
+          correctorMap = (\f -> foldl f Map.empty correctors) (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
+              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
+          E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
+          let numSubmittors = E.sub_select . E.from $ \subUser -> do
+                E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
+                return E.countRows
+          return (submission, numSubmittors)
+      -- prepare map
+      let infoMap  :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
+          infoMap  = List.foldl (flip buildS) emptySheets submissions
+
+          -- ensure that all sheets are shown, including those without any submissions
+          emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds
+          emptyCorrs  = foldl (\m uid -> let cic = Just uid in
+                                         Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap
+
+
+          buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo)
+          buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m =
+              let shnm    = sheetName $ sheets ! submissionSheet
+                  corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned
+                  cinf    = Map.singleton submissionRatingBy $ CorrectionInfo
+                            { ciSubmittors  = fromIntegral nrSbmtrs
+                            , ciSubmissions = 1
+                            , ciAssigned    = maybe 0 (const 1) submissionRatingBy   -- only used in sheetMap
+                            , ciCorrected   = maybe 0 (const 1) submissionRatingTime
+                            , ciCorrector   = submissionRatingBy
+                            , ciMin = corTime
+                            , ciTot = corTime
+                            , ciMax = corTime
+                            }
+              in Map.insertWith (Map.unionWith (<>)) shnm cinf m
+
+      return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
+
+  let -- infoMap  :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
+      -- create aggregate maps
+      sheetMap :: Map SheetName CorrectionInfo
+      sheetMap = Map.map fold infoMap
+      corrMap  :: Map (Maybe UserId) CorrectionInfo
+      corrMap  = Map.unionsWith (<>) $ Map.elems infoMap
+      sheetNames = Map.keys infoMap
+  let -- whamlet convenience functions
+      -- avoid nestes hamelt $maybe with duplicated $nothing
+      getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector)
+      getCorrector (Just uid)
+        | Just (User{..},loadMap) <- Map.lookup uid correctorMap
+        = (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 = foldMap formatDiffDays
+      showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
+      showAvgsDays Nothing   _ = mempty
+      showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
+      heat :: Integer -> Integer -> Double
+      heat full achieved = roundToDigits 3 $ cutOffPercent 0.4 (fromIntegral full) (fromIntegral achieved)
+  let headingShort
+        | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
+        | otherwise               = MsgMenuCorrectionsAssign
+      headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
+  siteLayoutMsg headingShort $ do
+    setTitleI headingLong
+    $(widgetFile "corrections-overview")
+
+
+

src/Handler/Tutorial.hs

@@ -136,7 +136,7 @@ postTDeleteR tid ssh csh tutn = do
               return E.countRows
         return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
     , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
-        return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|]
+        return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|]
     , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
         return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
     , drCaption = SomeMessage MsgTutorialDeleteQuestion
@@ -199,7 +199,7 @@ postTCommR tid ssh csh tutn = do
         [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser ->
           E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
                E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid
-        
+
         isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False
         isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False
 

src/Handler/Utils/Corrections.hs

@@ -0,0 +1,45 @@
+module Handler.Utils.Corrections where
+
+import Import
+
+
+-- CorrectionInfo has seeming redundancies, but these are useful for aggregation
+-- INVARIANT: isJust ciTot `implies` ciCorrected > 0
+data CorrectionInfo = CorrectionInfo
+      { ciSubmittors, ciSubmissions, ciAssigned, ciCorrected :: Integer
+      , ciCorrector :: Maybe UserId
+      , ciTot, ciMin,  ciMax :: Maybe NominalDiffTime
+      }
+
+instance Semigroup CorrectionInfo where
+  corrA <> corrB =
+        assert (isJust (ciTot corrA) `implies` (ciCorrected corrA > 0)) $
+        assert (isJust (ciTot corrB) `implies` (ciCorrected corrB > 0))
+        CorrectionInfo
+          { ciSubmittors  = ciSubmittors  `mergeWith` (+)
+          , ciSubmissions = ciSubmissions `mergeWith` (+)
+          , ciAssigned    = ciAssigned    `mergeWith` (+)
+          , ciCorrected   = ciCorrected   `mergeWith` (+)
+          , ciCorrector   = ciCorrector   `mergeWith` keepEqual
+          , ciTot         = ciTot `mergeWith` ignoreNothing (+)
+          , ciMin         = ciMin `mergeWith` ignoreNothing min
+          , ciMax         = ciMax `mergeWith` ignoreNothing max
+          }
+    where
+      mergeWith :: (CorrectionInfo -> a) -> (a -> a -> c) -> c
+      mergeWith prj f = on f prj corrA corrB
+
+      keepEqual (Just x) (Just y) | x==y = Just x
+      keepEqual _ _ = Nothing
+
+instance Monoid CorrectionInfo where
+  mappend = (<>)
+  mempty  = CorrectionInfo  { ciSubmittors  = 0
+                            , ciSubmissions = 0
+                            , ciAssigned    = 0
+                            , ciCorrected   = 0
+                            , ciCorrector   = Nothing
+                            , ciMin         = Nothing
+                            , ciTot         = Nothing
+                            , ciMax         = Nothing
+                            }

src/Handler/Utils/DateTime.hs

@@ -2,6 +2,7 @@ module Handler.Utils.DateTime
   ( utcToLocalTime
   , localTimeToUTC, TZ.LocalToUTCResult(..)
   , toMidnight, beforeMidnight, toMidday, toMorning
+  , formatDiffDays
   , formatTime, formatTime', formatTimeW
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
@@ -29,6 +30,37 @@ import qualified Data.Set as Set
 import Data.Time.Clock.System (systemEpochDay)
 
 
+
+--------------------
+-- NominalDiffTime
+
+-- | One hour in 'NominalDiffTime'.
+nominalHour :: NominalDiffTime
+nominalHour = 3600
+
+-- | One minute in 'NominalDiffTime'.
+nominalMinute :: NominalDiffTime
+nominalMinute= 60
+
+formatDiffDays :: NominalDiffTime -> Text
+formatDiffDays t
+  | t > nominalDay    = inDays    <> "d"
+  | t > nominalHour   = inHours   <> "h"
+  | t > nominalMinute = inMinutes <> "m"
+  | otherwise         = tshow $ roundToDigits 0 t
+  where
+    convertBy :: NominalDiffTime -> Double
+    convertBy len = realToFrac $ roundToDigits 1 $ t / len
+    inDays    = tshow $ convertBy nominalDay
+    inHours   = tshow $ convertBy nominalHour
+    inMinutes = tshow $ convertBy nominalMinute
+
+
+
+------------
+-- UTCTime
+
+
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
 
@@ -52,7 +84,6 @@ toMorning :: Day -> UTCTime
 toMorning      d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 6 0 0
 
 
-
 class FormatTime t => HasLocalTime t where
   toLocalTime :: t -> LocalTime
 

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,7 +66,32 @@ 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
+
+-- | 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
+        lift $ update subId [ SubmissionRatingBy       =. Just corrector
+                            , SubmissionRatingAssigned =. Just now
+                            ]
+        tell (Set.singleton subId, mempty)
+      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!
+--   May throw an exception if there are no suitable correctors
+planSubmissions :: SheetId -- ^ Sheet to distribute to correctors
+                  -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
+                  -> YesodDB UniWorX (Map SubmissionId (Maybe UserId))
+                  -- ^ Return map that assigns submissions to Corrector
+planSubmissions sid restriction = do
     Sheet{..} <- getJust sid
     correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
       E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@@ -210,15 +235,7 @@ assignSubmissions sid restriction = do
 
         ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
 
-    now <- liftIO getCurrentTime
+    return $ fmap (view _1) newSubmissionData
-    execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of
-      Just corrector -> do
-        lift $ update subId [ SubmissionRatingBy       =. Just corrector
-                            , SubmissionRatingAssigned =. Just now
-                            ]
-        tell (Set.singleton subId, mempty)
-      Nothing ->
-        tell (mempty, Set.singleton subId)
   where
     maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a
     maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs

src/Model/Types/Sheet.hs

@@ -305,3 +305,15 @@ instance Hashable 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  =        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 "

src/Utils.hs

@@ -343,6 +343,17 @@ notUsedT = notUsed
 
 
 
+----------
+-- Bool --
+----------
+
+-- | Logical implication, readable synonym for (<=) which appears the wrong way around
+implies :: Bool -> Bool -> Bool
+implies True x = x
+implies _    _ = True
+
+
+
 -------------
 -- Numeric --
 -------------
@@ -368,6 +379,19 @@ roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
 roundDiv digits numerator denominator
   = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator
 
+-- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all
+--   `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved)
+--   Useful for heat maps, with offset giving a visual step between completed and not yet completed
+cutOffPercent :: Double -> Double -> Double -> Double
+cutOffPercent offset full achieved
+  | full <= achieved = 0
+  | full <= 0        = 0
+  | otherwise        = offset + (1-offset * (1 - percent))
+  where
+    percent = achieved / full
+
+
+
 ------------
 -- Monoid --
 ------------
@@ -489,6 +513,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 --
@@ -523,12 +552,6 @@ flipMaybe :: b -> Maybe a -> Maybe b
 flipMaybe x Nothing  = Just x
 flipMaybe _ (Just _) = Nothing
 
-
-maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap
-maybeAdd (Just x) (Just y) = Just (x + y)
-maybeAdd Nothing y  = y
-maybeAdd x Nothing  = x
-
 -- | Deep alternative to avoid any occurrence of Nothing at all costs, left-biased
 deepAlt :: Maybe (Maybe a) -> Maybe (Maybe a) -> Maybe (Maybe a)
 deepAlt Nothing        altSnd  = altSnd
@@ -574,6 +597,12 @@ mcons :: Maybe a -> [a] -> [a]
 mcons Nothing  xs = xs
 mcons (Just x) xs = x:xs
 
+-- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap
+ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
+ignoreNothing _ Nothing y = y
+ignoreNothing _ x Nothing = x
+ignoreNothing f (Just x) (Just y) = Just $ f x y
+
 newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
 
 instance Eq a  => Eq (NTop (Maybe a)) where

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,77 @@
+<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 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}
+        <td .table__td>#{ciSubmissions}
+        $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment
+          $if 0 < Set.size sfailed
+            <td .table__td>#{ciSubmissions - ciAssigned}
+            <td .table__td .alert-danger>(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)})
+          $elseif 0 < Set.size splus
+            <td .table__td>#{ciSubmissions - ciAssigned}
+            <td .table__td .alert-success>(-#{show (Set.size splus)})
+          $else
+            <td .table__td colspan=2>#{ciSubmissions - ciAssigned}
+        $nothing
+          <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=5>#{shn}
+        $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
+    $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap
+      $with (nameW,loadM) <- getCorrector ciCorrector
+        <tr .table__row>
+          <td .table__td>^{nameW}
+          <td .table__td>#{ciSubmissions}
+          <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
+          <td .table__td>#{showDiffDays ciMin}
+          <td .table__td>#{showAvgsDays ciTot ciCorrected}
+          <td .table__td>#{showDiffDays ciMax}
+          $forall shn <- sheetNames
+            $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
+              <td .table__td>#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
+            $nothing
+              <td .table__td>
+            $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
+              $maybe nrNew <- getCorrNewAssignment ciCorrector shn
+                <td .table__td>#{ciSubmissions}
+                $# <td .table__td>#{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap`
+                <td .table__td .alert-success>(+#{nrNew})
+              $nothing
+                <td .table__td colspan=2>#{ciSubmissions}
+              <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
+              <td .table__td>#{showAvgsDays ciTot ciCorrected}
+            $nothing
+              <td .table__td colspan=4>
+    $if 0 < length sheetNames
+      <tr .table__row>
+        <td colspan=6>
+        $forall shn <- sheetNames
+          <td .table__td colspan=5>^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
+  ^{btnWdgt}
+ <div>
+  <p>_{MsgAssignSubmissionsRandomWarning}

templates/default-layout.lucius

@@ -565,6 +565,7 @@ section {
   color: var(--color-dark);
   box-shadow: 0 0 4px 2px inset currentColor;
   padding-left: 20%;
+  min-height: 100px;
 
   &::before {
     content: 'i';
@@ -579,6 +580,10 @@ section {
     justify-content: center;
   }
 }
+  
+.form-group__input > .notification {
+  margin: 0;
+}
 
 @media (max-width: 768px) {
 
@@ -606,3 +611,29 @@ section {
 .notification__content {
   color: var(--color-font);
 }
+
+
+
+
+/*
+  "Heated" element.
+  Set custom property "--hotness" to a value from 0 to 1 to turn
+  the element's background to a color on a gradient from green to red.
+
+  TBD:
+  - move to a proper place
+  - think about font-weight...
+
+  Example:
+  <div .heated style="--hotness: 0.2">Lorem ipsum
+*/
+
+.heated {
+  --hotness: 0;
+  --red: calc(var(--hotness) * 200);
+  --green: calc(255 - calc(var(--hotness) * 255));
+  --opacity: calc(calc(var(--red) / 600) + 0.1);
+
+  font-weight: var(--weight, 600);
+  background-color: rgba(var(--red), var(--green), 0, var(--opacity));
+}