From 228cd507498a74f92978c2c9082d91348e68c564 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 15:08:03 +0200 Subject: [PATCH 1/4] feat(corrector-assignment): show load/submission percentages --- messages/uniworx/de.msg | 2 +- src/Handler/Corrections.hs | 15 +++++--- src/Handler/Health.hs | 4 +-- src/Handler/Sheet.hs | 4 +-- src/Utils.hs | 34 +++++++++++++------ templates/corrections-overview.hamlet | 32 ++++++++++++----- .../grading-summary-row.hamlet | 4 +-- 7 files changed, 63 insertions(+), 32 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index cd7300b09..012b6b587 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -322,7 +322,7 @@ Correctors: Korrektoren CorState: Status CorByTut: Zuteilung nach Tutorium CorProportion: Anteil -CorDeficit: Defizit +CorDeficitProportion: Defizit Anteile CorByProportionOnly proportion@Rational: #{display proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 81335f4ac..f62fc6487 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1214,6 +1214,9 @@ assignHandler tid ssh csh cid assignSids = do let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps + sheetNames :: [SheetName] + sheetNames = Map.keys infoMap + sheetMap :: Map SheetName CorrectionInfo sheetMap = Map.map fold infoMap @@ -1230,7 +1233,10 @@ assignHandler tid ssh csh cid assignSids = do corrMap :: Map (Maybe UserId) CorrectionInfo corrMap = Map.unionsWith (<>) $ Map.elems infoMap - sheetNames = Map.keys infoMap + + corrMapSum :: CorrectionInfo + corrMapSum = fold corrMap + let -- whamlet convenience functions -- avoid nestes hamlet $maybe with duplicated $nothing getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector) @@ -1256,10 +1262,9 @@ assignHandler tid ssh csh cid assignSids = do getCorrDeficit _ = Nothing getLoadSum :: SheetName -> Text - getLoadSum shn - | (Just load) <- Map.lookup shn sheetLoad - = "Σ" <> showCompactCorrectorLoad load CorrectorNormal - getLoadSum _ = mempty + getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad + = showCompactCorrectorLoad load CorrectorNormal + getLoadSum _ = mempty showDiffDays :: Maybe NominalDiffTime -> Text showDiffDays = foldMap formatDiffDays diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 046c16aff..7b29e2bbd 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -63,7 +63,7 @@ getHealthR = do
#{boolSymbol passed} $of HealthLDAPAdmins (Just found)
_{MsgHealthLDAPAdmins} -
#{textPercent found} +
#{textPercent found 1} $of HealthSMTPConnect (Just passed)
_{MsgHealthSMTPConnect}
#{boolSymbol passed} @@ -80,7 +80,7 @@ getInstanceR = do instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID setWeakEtagHashable (clusterId, instanceId) - + selectRep $ do provideRep $ siteLayoutMsg MsgInstanceIdentification $ do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c14424251..791bce180 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -257,9 +257,7 @@ getSheetListR tid ssh csh = do (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> case preview (_grading . _maxPoints) sType of Just maxPoints - | maxPoints /= 0 -> - let percent = sPoints / maxPoints - in textCell $ textPercent $ realToFrac percent + | maxPoints /= 0 -> textCell $ textPercent sPoints maxPoints _other -> mempty _other -> mempty ] diff --git a/src/Utils.hs b/src/Utils.hs index 4f565befe..e02a8b9b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -2,12 +2,13 @@ module Utils ( module Utils ) where -import ClassyPrelude.Yesod hiding (foldlM) +import ClassyPrelude.Yesod hiding (foldlM, Proxy) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold import Data.Foldable as Utils (foldlM, foldrM) import Data.Monoid (Sum(..)) +import Data.Proxy import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -67,7 +68,7 @@ import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Data.PKCS7 as PKCS7 import Data.Fixed -import Data.Ratio ((%)) +-- import Data.Ratio ((%)) import Data.Binary (Binary) import qualified Data.Binary as Binary @@ -293,15 +294,28 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out display = pack . show -} -textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? -textPercent x = lz <> pack (show rx) <> "%" - where - rx :: Centi - rx = realToFrac (x * 100) - lz = if rx < 10.0 then "0" else "" +-- | Convert `part` and `whole` into percentage including symbol +-- showing trailing zeroes and to decimal digits +textPercent :: Real a => a -> a -> Text +textPercent = textPercent' False 2 + +-- | Convert `part` and `whole` into percentage including symbol +-- `trailZero` shows trailing Zeros, `precision` is number of decimal digits +textPercent' :: Real a => Bool -> Int -> a -> a -> Text +textPercent' trailZero precision part whole + | precision == 0 = showPercent (frac :: Uni) + | precision == 1 = showPercent (frac :: Deci) + | precision == 2 = showPercent (frac :: Centi) + | precision == 3 = showPercent (frac :: Milli) + | precision == 4 = showPercent (frac :: Micro) + | otherwise = showPercent (frac :: Pico) + where + frac :: forall a . HasResolution a => Fixed a + frac = MkFixed $ round $ (* (fromInteger $ resolution (Proxy :: Proxy a))) $ (100*) $ toRational part / toRational whole + + showPercent :: HasResolution a => Fixed a -> Text + showPercent f = pack $ showFixed trailZero f <> "%" -textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? -textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole -- | Convert number of bytes to human readable format textBytes :: Integral a => a -> Text diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 5d3f6ba8b..c4d4c0f3c 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -45,7 +45,7 @@ _{MsgCorrector} _{MsgGenericAll} - _{MsgCorProportion} + _{MsgCorDeficitProportion} _{MsgCorrectionTime} $forall shn <- sheetNames #{shn} @@ -53,7 +53,6 @@ _{MsgNrSubmissionsTotal} _{MsgNrSubmissionsNotCorrected} - _{MsgCorDeficit} _{MsgGenericMin} _{MsgGenericAvg} _{MsgGenericMax} @@ -63,24 +62,33 @@ _{MsgGenericNumChange} _{MsgNrSubmissionsNotCorrectedShort} _{MsgGenericAvg} - $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap + $forall (CorrectionInfo{ciCorrector, ciSubmissions=ciSubmissionsNr, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap $with (nameW,loadM) <- getCorrector ciCorrector ^{nameW} - #{ciSubmissions} - #{ciSubmissions - ciCorrected} + #{ciSubmissionsNr} + $with total <- ciSubmissions corrMapSum + $if total > 0 + \ (#{textPercent' True 0 ciSubmissionsNr total}) + #{ciSubmissionsNr - ciCorrected} $maybe deficit <- getCorrDeficit ciCorrector #{display deficit} #{showDiffDays ciMin} #{showAvgsDays ciTot ciCorrected} #{showDiffDays ciMax} - $forall shn <- sheetNames + $forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- Map.toList sheetMap $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} + $if sheetCorrectorState == CorrectorNormal + $maybe Load{byProportion=total} <- Map.lookup shn sheetLoad + $if total > 0 + \ (#{textPercent' True 0 (byProportion sheetCorrectorLoad) total}) $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn #{ciSubmissions} + $if sheetSubmissionsNr > 0 + \ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr}) $maybe nrNew <- getCorrNewAssignment ciCorrector shn $# #{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap` (+#{nrNew}) @@ -95,10 +103,16 @@ $if 0 < length sheetNames - + Σ + #{ciSubmissions corrMapSum} + #{ciCorrected corrMapSum} + + #{showDiffDays (ciMin corrMapSum)} + #{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)} + #{showDiffDays (ciMax corrMapSum)} $forall shn <- sheetNames - #{getLoadSum shn} - ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} + #{getLoadSum shn} + ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} ^{btnWdgt}

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file diff --git a/templates/widgets/grading-summary/grading-summary-row.hamlet b/templates/widgets/grading-summary/grading-summary-row.hamlet index 261b98e1a..0e64a515b 100644 --- a/templates/widgets/grading-summary/grading-summary-row.hamlet +++ b/templates/widgets/grading-summary/grading-summary-row.hamlet @@ -19,7 +19,7 @@ $# $with Sum pacv <- summary ^. _achievedPasses $if pmax > 0 - #{textPercentInt pacv pmax} + #{textPercent pacv pmax} #{display pacv} / #{display pmax} $else @@ -35,7 +35,7 @@ $# $with Sum pacv <- summary ^. _achievedPoints $if pmax > 0 - #{textPercent $ realToFrac $ pacv / pmax} + #{textPercent pacv pmax} #{display pacv} / #{display pmax} $if ((summary ^. _numMarkedPoints) /= (summary ^. _numSheets)) From 749cd2f7bcf990f5eee18d90099843151cb56716 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 15:22:46 +0200 Subject: [PATCH 2/4] fix(sheet corrector assigment): minor bugfix --- templates/corrections-overview.hamlet | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index c4d4c0f3c..94ada0543 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -104,15 +104,17 @@ $if 0 < length sheetNames Σ - #{ciSubmissions corrMapSum} + $with ciSubmissionsNr <- ciSubmissions corrMapSum + $with ciCorrectedNr <- ciCorrected corrMapSum + #{ciSubmissionsNr} + #{ciSubmissionsNr - ciCorrectedNr} #{ciCorrected corrMapSum} - #{showDiffDays (ciMin corrMapSum)} #{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)} #{showDiffDays (ciMax corrMapSum)} $forall shn <- sheetNames #{getLoadSum shn} - ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} + ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} ^{btnWdgt}

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file From 89d5364c937132a642d7b7960e90b73868fe56f4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 19:35:49 +0200 Subject: [PATCH 3/4] fix(Help Widget, Corrector Assignment): Modal Form closes in place; assign alerts Closes #195 --- .directory | 2 +- messages/uniworx/de.msg | 2 ++ src/Foundation.hs | 4 +-- src/Handler/Corrections.hs | 69 ++++++++++---------------------------- src/Handler/Help.hs | 2 +- src/Handler/Profile.hs | 4 +-- src/Utils/Form.hs | 5 +++ 7 files changed, 31 insertions(+), 57 deletions(-) diff --git a/.directory b/.directory index 59c2c250d..9e958424d 100644 --- a/.directory +++ b/.directory @@ -1,5 +1,5 @@ [Dolphin] -Timestamp=2018,3,14,10,57,55 +Timestamp=2019,6,26,19,32,25 Version=4 [Settings] diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 012b6b587..2195c86a5 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -203,6 +203,7 @@ SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausg SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden SheetNoCurrent: Es gibt momentan kein aktives Übungsblatt. SheetNoOldUnassigned: Alle Abgaben inaktiver Blätter sind bereits einen Korrektor zugeteilt. +SheetsUnassignable name@Text: Momentan keine Abgaben zuteilbar für #{name} Deadline: Abgabe Done: Eingereicht @@ -403,6 +404,7 @@ UpdatedSheetCorrectorsAutoFailed n@Int: #{display n} #{pluralDE n "Abgabe konnte 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 3e243af41..ed6a01a70 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1436,7 +1436,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 ("Zuteilung" , Just $ CourseR tid ssh csh CCorrectionsR) + breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilung Korrekturen" , 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) @@ -1454,7 +1454,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten" , Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen" , Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben" , Just $ CSheetR tid ssh csh shn SShowR) - breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilen" , Just $ CSheetR tid ssh csh shn SSubsR) + breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilung Korrekturen" , Just $ CSheetR tid ssh csh shn SSubsR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index f62fc6487..446b93273 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1052,11 +1052,8 @@ data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiC getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAssignR = postCAssignR postCAssignR tid ssh csh = do - (shids,cid) <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - shids <- selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] - return (shids,cid) - assignHandler tid ssh csh cid shids + cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh + assignHandler tid ssh csh cid [] getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSAssignR = postSAssignR @@ -1064,51 +1061,13 @@ postSAssignR tid ssh csh shn = do (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn assignHandler tid ssh csh cid [shid] --- 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 - Just Sheet{sheetName=saiName} <- lift $ get sid - guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh saiName SAssignR -- we must check, whether the submission is already closed and thus assignable - saiUnassignedNr <- lift $ count [SubmissionSheet ==. sid, SubmissionRatingBy ==. Nothing] - guard $ 0 < saiUnassignedNr -- only consider sheets with unassigned submissions - saiSubmissionNr <- lift $ count [SubmissionSheet ==. sid] - saiCorrectorNr <- lift $ count [SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal] - -- guard $ saiCorrectorNr > 0 -- COMMENTED OUT BECAUSE we should show sheets without possible correctors to inform the user about these problematic sheets - return $ Map.insert sid SubAssignInfo{..} acc - let sids = Map.keys openSubs - linkBack <- simpleLinkI (SomeMessage MsgGenericBack) <$> case sids of - [sid] -> do Sheet{sheetName} <- runDB $ getJust sid - return $ CSheetR tid ssh csh sheetName SSubsR - _ -> return $ CourseR tid ssh csh CCorrectionsR - -- process form - currentRoute <- getCurrentRoute - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm FIDAssignSubmissions buttonForm - assignmentStatus <- fmap (fromMaybe Map.empty) . formResultMaybe btnResult $ \BtnSubmissionsAssign -> - -- Assign submissions - fmap Just . runDB $ (\f -> foldM f Map.empty sids) $ - \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 - , formEncoding = btnEnctype - , formSubmit = FormNoSubmit - } - headingShort = MsgMenuCorrectionsAssign - headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign - siteLayoutMsg headingShort $ do - setTitleI headingLong - $(widgetFile "corrections-assign") - if null sids || not (null assignmentStatus) - 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: Feature: + make distivt buttons for each sheet, so that users see which sheet will be assigned. + Currently this information is available within the page heading! - -{- TODO: make buttons for each sheet, so that users see which sheet is assigned + Stub: data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Button UniWorX ButtonCorrectionsAssign -- Are those needed any more? instance Universe ButtonCorrectionsAssign @@ -1126,7 +1085,7 @@ assignHandler tid ssh csh cid assignSids = do (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions -- gather data - (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do + (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid] @@ -1137,6 +1096,7 @@ assignHandler tid ssh csh cid assignSids = do groupsPossible = let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups in List.foldr foldFun False sheetList + assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids -- plan or assign unassigned submissions for given sheets let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) @@ -1166,7 +1126,10 @@ assignHandler tid ssh csh cid assignSids = do addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] return status return $ Map.insert shn (status, countMapElems plan, deficit) acc - assignment <- foldM buildA Map.empty assignSids + assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts + then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] + else return assignSids + 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 @@ -1210,7 +1173,7 @@ assignHandler tid ssh csh cid assignSids = do } in Map.insertWith (Map.unionWith (<>)) shnm cinf m - return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) + return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps @@ -1277,6 +1240,10 @@ assignHandler tid ssh csh cid assignSids = do | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment | otherwise = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign + + unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames + unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets + siteLayoutMsg headingShort $ do setTitleI headingLong $(widgetFile "corrections-overview") diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index bf33da8d5..5380d9880 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -66,6 +66,6 @@ postHelpR = do let formWidget = wrapForm formWidget' def { formAction = Just $ SomeRoute HelpR , formEncoding = formEnctype - , formAttrs = [ ("data-ajax-submit", "") | isModal ] + , formAttrs = [ asyncSubmitAttr | isModal ] } $(widgetFile "help") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 403e133c7..282286f4f 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -147,7 +147,7 @@ postProfileR = do siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do setTitle . toHtml $ "Profil " <> userIdent - let settingsForm = + let settingsForm = wrapForm formWidget FormSettings { formMethod = POST , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings @@ -593,7 +593,7 @@ postUserNotificationR cID = do let formWidget = wrapForm nsInnerWdgt def { formAction = Just . SomeRoute $ UserNotificationR cID , formEncoding = nsEnc - , formAttrs = [ ("data-ajax-submit", "") | isModal ] + , formAttrs = [ asyncSubmitAttr | isModal ] } formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 69eb65254..b189485a5 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -156,6 +156,11 @@ inputReadonly = addAttr "readonly" "" addAutosubmit :: FieldSettings site -> FieldSettings site addAutosubmit = addAttr "uw-auto-submit-input" "" +-- | Asynchronous Submit, e.g. use with forms in modals +asyncSubmitAttr :: (Text,Text) +asyncSubmitAttr = ("uw-async-form", "") + + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ From 96387cbed5bda9b901706318e1931e6e718a0680 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 27 Jun 2019 08:55:32 +0200 Subject: [PATCH 4/4] fix(many occurrences throughout the project): Fix typo: occurence -> occurrence everywhere A typo between occurence in code and occurrence in tests prevented deployment. I changed all occurrences of "occurence" to the correct spelling, such that --- messages/uniworx/de.msg | 4 +- models/tutorials | 2 +- src/Handler/Admin.hs | 2 +- src/Handler/Course.hs | 2 +- src/Handler/Tutorial.hs | 8 +- .../Form/{Occurences.hs => Occurrences.hs} | 78 +++++++++---------- src/Handler/Utils/Table/Cells.hs | 18 ++--- src/Model/Types/DateTime.hs | 20 ++--- src/Utils/Lens.hs | 12 +-- src/Utils/{Occurences.hs => Occurrences.hs} | 30 +++---- .../{occurence => occurrence}/cell.hamlet | 6 +- .../cell/except-no-occur.hamlet | 0 .../cell/except-occur.hamlet | 0 .../cell/weekly.hamlet | 0 .../form/except-add.hamlet | 0 .../form/except-layout.hamlet | 0 .../form/except-no-occur.hamlet | 0 .../form/except-occur.hamlet | 0 .../form/scheduled-add.hamlet | 0 .../form/scheduled-layout.hamlet | 0 .../form/weekly.hamlet | 0 test/Database.hs | 12 +-- test/Model/TypesSpec.hs | 18 ++--- 23 files changed, 106 insertions(+), 106 deletions(-) rename src/Handler/Utils/Form/{Occurences.hs => Occurrences.hs} (63%) rename src/Utils/{Occurences.hs => Occurrences.hs} (73%) rename templates/widgets/{occurence => occurrence}/cell.hamlet (64%) rename templates/widgets/{occurence => occurrence}/cell/except-no-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/cell/except-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/cell/weekly.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-add.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-layout.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-no-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/scheduled-add.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/scheduled-layout.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/weekly.hamlet (100%) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2195c86a5..bf7943f8b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -965,8 +965,8 @@ ScheduleRegular: Planmäßiger Termin ScheduleRegularKind: Plan WeekDay: Wochentag Day: Tag -OccurenceStart: Beginn -OccurenceEnd: Ende +OccurrenceStart: Beginn +OccurrenceEnd: Ende ScheduleExists: Dieser Plan existiert bereits ScheduleExceptions: Termin-Ausnahmen diff --git a/models/tutorials b/models/tutorials index 4961e0bd5..166a8dbef 100644 --- a/models/tutorials +++ b/models/tutorials @@ -4,7 +4,7 @@ Tutorial json type (CI Text) -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial room Text - time Occurences + time Occurrences regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 6f13dba0c..1b6242611 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -165,7 +165,7 @@ postAdminTestR = do -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell) -- - -- This /needs/ to replace all occurences of @mreq@ with @mpreq@ (no fields should be /actually/ required) + -- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required) mkAddForm :: ListPosition -- ^ Approximate position of the add-widget -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3 -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5abd1e624..c31b7048c 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -360,7 +360,7 @@ getCShowR tid ssh csh = do ^{nameEmailWidget' tutor} |] , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index caeeb11c1..fe0820abf 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -8,7 +8,7 @@ import Handler.Utils.Tutorial import Handler.Utils.Table.Cells import Handler.Utils.Delete import Handler.Utils.Communication -import Handler.Utils.Form.Occurences +import Handler.Utils.Form.Occurrences import Handler.Utils.Invitations import Jobs.Queue @@ -64,7 +64,7 @@ getCTutorialListR tid ssh csh = do , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo @@ -275,7 +275,7 @@ data TutorialForm = TutorialForm , tfType :: CI Text , tfCapacity :: Maybe Int , tfRoom :: Text - , tfTime :: Occurences + , tfTime :: Occurrences , tfRegGroup :: Maybe (CI Text) , tfRegisterFrom :: Maybe UTCTime , tfRegisterTo :: Maybe UTCTime @@ -322,7 +322,7 @@ tutorialForm cid template html = do <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) - <*> occurencesAForm ("occurences" :: Text) (tfTime <$> template) + <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip diff --git a/src/Handler/Utils/Form/Occurences.hs b/src/Handler/Utils/Form/Occurrences.hs similarity index 63% rename from src/Handler/Utils/Form/Occurences.hs rename to src/Handler/Utils/Form/Occurrences.hs index da0e7733f..e3de0c461 100644 --- a/src/Handler/Utils/Form/Occurences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -1,5 +1,5 @@ -module Handler.Utils.Form.Occurences - ( occurencesAForm +module Handler.Utils.Form.Occurrences + ( occurrencesAForm ) where import Import @@ -12,33 +12,33 @@ import qualified Data.Map as Map import Utils.Lens - -data OccurenceScheduleKind = ScheduleKindWeekly + +data OccurrenceScheduleKind = ScheduleKindWeekly deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceScheduleKind -instance Finite OccurenceScheduleKind +instance Universe OccurrenceScheduleKind +instance Finite OccurrenceScheduleKind -nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceScheduleKind id +nullaryPathPiece ''OccurrenceScheduleKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceScheduleKind id -data OccurenceExceptionKind = ExceptionKindOccur +data OccurrenceExceptionKind = ExceptionKindOccur | ExceptionKindNoOccur deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceExceptionKind -instance Finite OccurenceExceptionKind +instance Universe OccurrenceExceptionKind +instance Finite OccurrenceExceptionKind -nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceExceptionKind id +nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id -occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences -occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do +occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences +occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do Just cRoute <- getCurrentRoute - + let - scheduled :: AForm Handler (Set OccurenceSchedule) + scheduled :: AForm Handler (Set OccurrenceSchedule) scheduled = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -47,16 +47,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__scheduled" :: Text) (fslI MsgScheduleRegular & setTooltip MsgMassInputTip) False - (Set.toList . occurencesScheduled <$> mPrev) + (Set.toList . occurrencesScheduled <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceSchedule] -> FormResult [OccurrenceSchedule]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do newSched <- multiActionW (Map.fromList [ ( ScheduleKindWeekly , ScheduleWeekly <$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -65,16 +65,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do | newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists] | otherwise -> FormSuccess $ pure newSched' - miCell' :: OccurenceSchedule -> Widget + miCell' :: OccurrenceSchedule -> Widget miCell' ScheduleWeekly{..} = do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/form/weekly") + $(widgetFile "widgets/occurrence/form/weekly") - miLayout' :: MassInputLayout ListLength OccurenceSchedule () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout") + miLayout' :: MassInputLayout ListLength OccurrenceSchedule () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/scheduled-layout") - exceptions :: AForm Handler (Set OccurenceException) + exceptions :: AForm Handler (Set OccurrenceException) exceptions = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -83,16 +83,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__exceptions" :: Text) (fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip])) False - (Set.toList . occurencesExceptions <$> mPrev) + (Set.toList . occurrencesExceptions <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceException] -> FormResult [OccurrenceException]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do newExc <- multiActionW (Map.fromList [ ( ExceptionKindOccur , ExceptOccur <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) , ( ExceptionKindNoOccur , ExceptNoOccur @@ -104,20 +104,20 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do return $ newExc <&> \newExc' oldExcs -> if | newExc' `elem` oldExcs -> FormFailure [mr MsgExceptionExists] | otherwise -> FormSuccess $ pure newExc' - - miCell' :: OccurenceException -> Widget + + miCell' :: OccurrenceException -> Widget miCell' ExceptOccur{..} = do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptEnd - $(widgetFile "widgets/occurence/form/except-occur") + $(widgetFile "widgets/occurrence/form/except-occur") miCell' ExceptNoOccur{..} = do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/form/except-no-occur") + $(widgetFile "widgets/occurrence/form/except-no-occur") - miLayout' :: MassInputLayout ListLength OccurenceException () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout") + miLayout' :: MassInputLayout ListLength OccurrenceException () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/except-layout") - aFormToWForm $ Occurences + aFormToWForm $ Occurrences <$> scheduled <*> exceptions diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 620e6776b..b901fb8d3 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Text.Blaze (ToMarkup(..)) import Utils.Lens import Handler.Utils -import Utils.Occurences +import Utils.Occurrences import qualified Data.Set as Set @@ -248,19 +248,19 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc -occurencesCell :: IsDBTable m a => Occurences -> DBCell m a -occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do - let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case +occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a +occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do + let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/cell/weekly") - occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case + $(widgetFile "widgets/occurrence/cell/weekly") + occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case ExceptOccur{..} -> do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptStart - $(widgetFile "widgets/occurence/cell/except-occur") + $(widgetFile "widgets/occurrence/cell/except-occur") ExceptNoOccur{..} -> do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/cell/except-no-occur") - $(widgetFile "widgets/occurence/cell") + $(widgetFile "widgets/occurrence/cell/except-no-occur") + $(widgetFile "widgets/occurrence/cell") diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 10783550e..c72a6ba37 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -2,7 +2,7 @@ Module: Model.Types.DateTime Description: Time related types -Terms, Seasons, and Occurence schedules +Terms, Seasons, and Occurrence schedules -} module Model.Types.DateTime ( module Model.Types.DateTime @@ -152,7 +152,7 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 termYear = year term -data OccurenceSchedule = ScheduleWeekly +data OccurrenceSchedule = ScheduleWeekly { scheduleDayOfWeek :: WeekDay , scheduleStart :: TimeOfDay , scheduleEnd :: TimeOfDay @@ -164,9 +164,9 @@ deriveJSON defaultOptions , constructorTagModifier = camelToPathPiece' 1 , tagSingleConstructors = True , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule + } ''OccurrenceSchedule -data OccurenceException = ExceptOccur +data OccurrenceException = ExceptOccur { exceptDay :: Day , exceptStart :: TimeOfDay , exceptEnd :: TimeOfDay @@ -180,15 +180,15 @@ deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException + } ''OccurrenceException -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException +data Occurrences = Occurrences + { occurrencesScheduled :: Set OccurrenceSchedule + , occurrencesExceptions :: Set OccurrenceException } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences + } ''Occurrences +derivePersistFieldJSON ''Occurrences diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b4cd5a572..7ebf61d99 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -111,15 +111,15 @@ makeLenses_ ''SubmissionMode makePrisms ''E.Value -makeLenses_ ''OccurenceSchedule +makeLenses_ ''OccurrenceSchedule -makePrisms ''OccurenceSchedule +makePrisms ''OccurrenceSchedule -makeLenses_ ''OccurenceException +makeLenses_ ''OccurrenceException -makePrisms ''OccurenceException +makePrisms ''OccurrenceException -makeLenses_ ''Occurences +makeLenses_ ''Occurrences makeLenses_ ''PredDNF @@ -132,6 +132,6 @@ makeLenses_ ''PredDNF class HasInstanceID s a | s -> a where instanceID :: Lens' s a - + class HasJSONWebKeySet s a | s -> a where jsonWebKeySet :: Lens' s a diff --git a/src/Utils/Occurences.hs b/src/Utils/Occurrences.hs similarity index 73% rename from src/Utils/Occurences.hs rename to src/Utils/Occurrences.hs index 077d79250..a5e271136 100644 --- a/src/Utils/Occurences.hs +++ b/src/Utils/Occurrences.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -module Utils.Occurences - ( normalizeOccurences +module Utils.Occurrences + ( normalizeOccurrences ) where import ClassyPrelude @@ -20,21 +20,21 @@ import Data.Time import Data.Time.Calendar.WeekDate -normalizeOccurences :: Occurences -> Occurences --- ^ +normalizeOccurrences :: Occurrences -> Occurrences +-- ^ -- -- - Removes unnecessary exceptions -- - Merges overlapping schedules -normalizeOccurences initial +normalizeOccurrences initial | Left new <- runReader (runExceptT go) initial - = normalizeOccurences new + = normalizeOccurrences new | otherwise = initial where - go :: ExceptT Occurences (Reader Occurences) () + go :: ExceptT Occurrences (Reader Occurrences) () -- Find some inconsistency and `throwE` a version without it go = do - scheduled <- view _occurencesScheduled + scheduled <- view _occurrencesScheduled forM_ scheduled $ \case a@ScheduleWeekly{} -> do let @@ -50,35 +50,35 @@ normalizeOccurences initial | otherwise = Nothing merge _ = Nothing - merges <- views _occurencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a + merges <- views _occurrencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a case merges of [] -> return () - ((b, merged) : _) -> throwE =<< asks (over _occurencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) + ((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) - exceptions <- view _occurencesExceptions + exceptions <- view _occurrencesExceptions forM_ exceptions $ \case needle@ExceptNoOccur{..} -> do let LocalTime{..} = exceptTime (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay - needed <- views _occurencesScheduled . any $ \case + needed <- views _occurrencesScheduled . any $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart <= localTimeOfDay , localTimeOfDay <= scheduleEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.delete needle) + throwE =<< asks (over _occurrencesExceptions $ Set.delete needle) needle@ExceptOccur{..} -> do let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay -- | Does this ExceptNoOccur target within needle? withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime && exceptTime <= LocalTime exceptDay exceptEnd withinNeedle _ = False - needed <- views _occurencesScheduled . none $ \case + needed <- views _occurrencesScheduled . none $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart == exceptStart , scheduleEnd == exceptEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) + throwE =<< asks (over _occurrencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) diff --git a/templates/widgets/occurence/cell.hamlet b/templates/widgets/occurrence/cell.hamlet similarity index 64% rename from templates/widgets/occurence/cell.hamlet rename to templates/widgets/occurrence/cell.hamlet index bb1f1f3d7..295b3ae24 100644 --- a/templates/widgets/occurence/cell.hamlet +++ b/templates/widgets/occurrence/cell.hamlet @@ -1,12 +1,12 @@ $newline never

    - $forall sched <- occurencesScheduled' + $forall sched <- occurrencesScheduled'
  • ^{sched} -$if not (null occurencesExceptions) +$if not (null occurrencesExceptions) $#
    $#
    $#
      - $forall exc <- occurencesExceptions' + $forall exc <- occurrencesExceptions'
    • ^{exc} diff --git a/templates/widgets/occurence/cell/except-no-occur.hamlet b/templates/widgets/occurrence/cell/except-no-occur.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-no-occur.hamlet rename to templates/widgets/occurrence/cell/except-no-occur.hamlet diff --git a/templates/widgets/occurence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occur.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-occur.hamlet rename to templates/widgets/occurrence/cell/except-occur.hamlet diff --git a/templates/widgets/occurence/cell/weekly.hamlet b/templates/widgets/occurrence/cell/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/cell/weekly.hamlet rename to templates/widgets/occurrence/cell/weekly.hamlet diff --git a/templates/widgets/occurence/form/except-add.hamlet b/templates/widgets/occurrence/form/except-add.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-add.hamlet rename to templates/widgets/occurrence/form/except-add.hamlet diff --git a/templates/widgets/occurence/form/except-layout.hamlet b/templates/widgets/occurrence/form/except-layout.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-layout.hamlet rename to templates/widgets/occurrence/form/except-layout.hamlet diff --git a/templates/widgets/occurence/form/except-no-occur.hamlet b/templates/widgets/occurrence/form/except-no-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-no-occur.hamlet rename to templates/widgets/occurrence/form/except-no-occur.hamlet diff --git a/templates/widgets/occurence/form/except-occur.hamlet b/templates/widgets/occurrence/form/except-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-occur.hamlet rename to templates/widgets/occurrence/form/except-occur.hamlet diff --git a/templates/widgets/occurence/form/scheduled-add.hamlet b/templates/widgets/occurrence/form/scheduled-add.hamlet similarity index 100% rename from templates/widgets/occurence/form/scheduled-add.hamlet rename to templates/widgets/occurrence/form/scheduled-add.hamlet diff --git a/templates/widgets/occurence/form/scheduled-layout.hamlet b/templates/widgets/occurrence/form/scheduled-layout.hamlet similarity index 100% rename from templates/widgets/occurence/form/scheduled-layout.hamlet rename to templates/widgets/occurrence/form/scheduled-layout.hamlet diff --git a/templates/widgets/occurence/form/weekly.hamlet b/templates/widgets/occurrence/form/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/form/weekly.hamlet rename to templates/widgets/occurrence/form/weekly.hamlet diff --git a/test/Database.hs b/test/Database.hs index ea044ac75..f59df7ec2 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -586,9 +586,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now @@ -604,9 +604,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 3805809db..84596eabf 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -26,7 +26,7 @@ import Time.Types (WeekDay(..)) instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable - + instance Arbitrary Season where arbitrary = genericArbitrary shrink = genericShrink @@ -71,7 +71,7 @@ instance Arbitrary SheetGradeSummary where instance Arbitrary SheetGroup where arbitrary = genericArbitrary shrink = genericShrink - + instance Arbitrary SheetTypeSummary where arbitrary = genericArbitrary shrink = genericShrink @@ -79,7 +79,7 @@ instance Arbitrary SheetTypeSummary where instance Arbitrary SheetFileType where arbitrary = genericArbitrary shrink = genericShrink - + instance Arbitrary SubmissionFileType where arbitrary = genericArbitrary shrink = genericShrink @@ -151,7 +151,7 @@ instance Arbitrary AuthTag where shrink = genericShrink instance CoArbitrary AuthTag where coarbitrary = genericCoarbitrary - + instance Arbitrary AuthTagActive where arbitrary = AuthTagActive <$> arbitrary shrink = genericShrink @@ -180,7 +180,7 @@ instance Arbitrary AuthenticationMode where authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2) return $ AuthPWHash{..} ] - + shrink AuthLDAP = [] shrink (AuthPWHash _) = [AuthLDAP] @@ -199,18 +199,18 @@ instance Arbitrary Html where instance Arbitrary WeekDay where arbitrary = oneof $ map pure [minBound..maxBound] -instance Arbitrary OccurenceSchedule where +instance Arbitrary OccurrenceSchedule where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary OccurenceException where +instance Arbitrary OccurrenceException where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary Occurences where +instance Arbitrary Occurrences where arbitrary = genericArbitrary shrink = genericShrink - + spec :: Spec spec = do