diff --git a/.vscode/tasks.json b/.vscode/tasks.json index a2b36e1b4..1c0b71c32 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -58,6 +58,11 @@ "type": "npm", "script": "start", "problemMatcher": [] + }, + { + "type": "npm", + "script": "frontend:lint", + "problemMatcher": [] } ] } \ No newline at end of file diff --git a/CHANGELOG_DE.md b/CHANGELOG_DE.md index b99c31205..73c72574f 100644 --- a/CHANGELOG_DE.md +++ b/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 diff --git a/frontend/src/utils/async-table/async-table.js b/frontend/src/utils/async-table/async-table.js index ee662229d..0c9e9cb04 100644 --- a/frontend/src/utils/async-table/async-table.js +++ b/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) => { - const paginationParamKey = this._asyncTableId + '-pagination'; - const pagesizeParamKey = this._asyncTableId + '-pagesize'; - const pageParamKey = this._asyncTableId + '-page'; - - const paginationParamEl = this._pagesizeForm.querySelector('[name="' + paginationParamKey + '"]'); + _changePagesizeHandler = () => { const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href); - url.searchParams.set(pagesizeParamKey, event.target.value); - url.searchParams.set(pageParamKey, 0); + const formData = new FormData(this._pagesizeForm); - if (paginationParamEl) { - const encodedValue = encodeURIComponent(paginationParamEl.value); - url.searchParams.set(paginationParamKey, encodedValue); + for (var k of url.searchParams.keys()) { + url.searchParams.delete(k); } + + for (var kv of formData.entries()) { + url.searchParams.append(kv[0], kv[1]); + } + this._updateTableFrom(url.href); } diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5415d7578..22c502e1f 100644 --- a/messages/uniworx/de.msg +++ b/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"} diff --git a/models/sheets b/models/sheets index f8d21a6c2..138b50bf1 100644 --- a/models/sheets +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 4567440f8..ad0d88b3c 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index b865ee96e..b64959f0c 100644 --- a/src/Handler/Corrections.hs +++ b/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 qualified Data.Map as Map +import Data.Map.Strict (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] - 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', delete me soonish +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") + + + diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 2a98110c1..caeeb11c1 100644 --- a/src/Handler/Tutorial.hs +++ b/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 diff --git a/src/Handler/Utils/Corrections.hs b/src/Handler/Utils/Corrections.hs new file mode 100644 index 000000000..ca5d433d7 --- /dev/null +++ b/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 + } diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 16ab29afa..8297f7266 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 9bb44bf00..7cb28cfa5 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,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 - 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) + return $ fmap (view _1) newSubmissionData 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 diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 74fb91dc1..5e971fb1d 100644 --- a/src/Model/Types/Sheet.hs +++ b/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 " diff --git a/src/Utils.hs b/src/Utils.hs index e8f0d27f5..a6fa63d38 100644 --- a/src/Utils.hs +++ b/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 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..19d13e265 --- /dev/null +++ b/templates/corrections-overview.hamlet @@ -0,0 +1,77 @@ +
+

_{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} + $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment + $if 0 < Set.size sfailed + #{ciSubmissions - ciAssigned} + (-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)}) + $elseif 0 < Set.size splus + #{ciSubmissions - ciAssigned} + (-#{show (Set.size splus)}) + $else + #{ciSubmissions - ciAssigned} + $nothing + #{ciSubmissions - ciAssigned} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} +
+

_{MsgCorrectionCorrectors} + + + + +
_{MsgCorrector} + _{MsgNrSubmissionsTotal} + _{MsgNrSubmissionsNotCorrected} + _{MsgCorrectionTime} + $forall shn <- sheetNames + #{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 +
^{nameW} + #{ciSubmissions} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} + $forall shn <- sheetNames + $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM + #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} + $nothing + + $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn + $maybe nrNew <- getCorrNewAssignment ciCorrector shn + #{ciSubmissions} + $# #{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap` + (+#{nrNew}) + $nothing + #{ciSubmissions} + #{ciSubmissions - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + + $if 0 < length sheetNames +
+ $forall shn <- sheetNames + ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)} + ^{btnWdgt} +
+

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 8e9b86452..9db97efb6 100644 --- a/templates/default-layout.lucius +++ b/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: +

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)); +}