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 66a159c18..1b460503d 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 @@ -323,7 +324,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 @@ -404,6 +405,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 21349c919..ba5336f14 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -160,6 +160,7 @@ deriving instance Generic SheetR deriving instance Generic SubmissionR deriving instance Generic MaterialR deriving instance Generic TutorialR +deriving instance Generic ExamR deriving instance Generic (Route UniWorX) -- | Convenient Type Synonyms: @@ -1494,7 +1495,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) @@ -1518,7 +1519,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/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/Corrections.hs b/src/Handler/Corrections.hs index 81335f4ac..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,10 +1173,13 @@ 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 + sheetNames :: [SheetName] + sheetNames = Map.keys infoMap + sheetMap :: Map SheetName CorrectionInfo sheetMap = Map.map fold infoMap @@ -1230,7 +1196,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 +1225,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 @@ -1272,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/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/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/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/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index 9fb8118e4..753868a9e 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -12,7 +12,7 @@ import qualified Data.Map as Map import Utils.Lens - + data OccurrenceScheduleKind = ScheduleKindWeekly deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) @@ -36,7 +36,7 @@ embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do Just cRoute <- getCurrentRoute - + let scheduled :: AForm Handler (Set OccurrenceSchedule) scheduled = Set.fromList <$> massInputAccumA @@ -89,13 +89,13 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do newExc <- multiActionW (Map.fromList [ ( ExceptionKindOccur - , ExceptOccurr + , ExceptOccur <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) , ( ExceptionKindNoOccur - , ExceptNoOccurr + , ExceptNoOccur <$> apreq localTimeField (fslI MsgExceptionNoOccurAt & addName (nudge "no-occur-time")) Nothing ) ] @@ -104,14 +104,14 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do return $ newExc <&> \newExc' oldExcs -> if | newExc' `elem` oldExcs -> FormFailure [mr MsgExceptionExists] | otherwise -> FormSuccess $ pure newExc' - + miCell' :: OccurrenceException -> Widget - miCell' ExceptOccurr{..} = do + miCell' ExceptOccur{..} = do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptEnd $(widgetFile "widgets/occurrence/form/except-occur") - miCell' ExceptNoOccurr{..} = do + miCell' ExceptNoOccur{..} = do exceptTime' <- formatTime SelFormatDateTime exceptTime $(widgetFile "widgets/occurrence/form/except-no-occur") diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a16d088c2..b901fb8d3 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -256,11 +256,11 @@ occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do scheduleEnd' <- formatTime SelFormatTime scheduleEnd $(widgetFile "widgets/occurrence/cell/weekly") occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case - ExceptOccurr{..} -> do + ExceptOccur{..} -> do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptStart - $(widgetFile "widgets/occurrence/cell/except-occurr") - ExceptNoOccurr{..} -> do + $(widgetFile "widgets/occurrence/cell/except-occur") + ExceptNoOccur{..} -> do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurrence/cell/except-no-occurr") + $(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 aa0226c34..a1dad3e8d 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -166,14 +166,14 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "repeat" "schedule" } ''OccurrenceSchedule -data OccurrenceException = ExceptOccurr - { exceptDay :: Day - , exceptStart :: TimeOfDay - , exceptEnd :: TimeOfDay - } - | ExceptNoOccurr - { exceptTime :: LocalTime - } +data OccurrenceException = ExceptOccur + { exceptDay :: Day + , exceptStart :: TimeOfDay + , exceptEnd :: TimeOfDay + } + | ExceptNoOccur + { exceptTime :: LocalTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Utils.hs b/src/Utils.hs index e34abcd21..e51b9dd38 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 @@ -309,15 +310,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/src/Utils/Form.hs b/src/Utils/Form.hs index 86d757dec..8a5da1d54 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -168,6 +168,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 -- ------------------------------------------------ diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index a6f14183a..ad54b3d8d 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -137,6 +137,6 @@ makeLenses_ ''UTCTime 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/Occurrences.hs b/src/Utils/Occurrences.hs index 6de64fac3..28ebdab8d 100644 --- a/src/Utils/Occurrences.hs +++ b/src/Utils/Occurrences.hs @@ -21,7 +21,7 @@ import Data.Time.Calendar.WeekDate normalizeOccurrences :: Occurrences -> Occurrences --- ^ +-- ^ -- -- - Removes unnecessary exceptions -- - Merges overlapping schedules @@ -57,7 +57,7 @@ normalizeOccurrences initial exceptions <- view _occurrencesExceptions forM_ exceptions $ \case - needle@ExceptNoOccurr{..} -> do + needle@ExceptNoOccur{..} -> do let LocalTime{..} = exceptTime (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay needed <- views _occurrencesScheduled . any $ \case @@ -68,10 +68,10 @@ normalizeOccurrences initial ] unless needed $ throwE =<< asks (over _occurrencesExceptions $ Set.delete needle) - needle@ExceptOccurr{..} -> do + needle@ExceptOccur{..} -> do let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay -- | Does this ExceptNoOccur target within needle? - withinNeedle ExceptNoOccurr{..} = LocalTime exceptDay exceptStart <= exceptTime + withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime && exceptTime <= LocalTime exceptDay exceptEnd withinNeedle _ = False needed <- views _occurrencesScheduled . none $ \case diff --git a/stack.yaml b/stack.yaml index 67b72469b..ae77b3f1d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,4 +48,6 @@ extra-deps: - filepath-1.4.2 + - haskell-src-exts-util-0.2.1.2 + resolver: lts-10.5 diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 5d3f6ba8b..94ada0543 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,9 +103,17 @@ $if 0 < length sheetNames - + Σ + $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} + #{getLoadSum shn} ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} ^{btnWdgt}
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)) diff --git a/templates/widgets/occurence/form/except-layout.hamlet b/templates/widgets/occurence/form/except-layout.hamlet deleted file mode 100644 index 65352dd95..000000000 --- a/templates/widgets/occurence/form/except-layout.hamlet +++ /dev/null @@ -1,11 +0,0 @@ -$newline never - - - $forall coord <- review liveCoords lLength - - ^{cellWdgts ! coord} - - - ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/occurence/form/scheduled-add.hamlet b/templates/widgets/occurence/form/scheduled-add.hamlet deleted file mode 100644 index bcb16ecfa..000000000 --- a/templates/widgets/occurence/form/scheduled-add.hamlet +++ /dev/null @@ -1,5 +0,0 @@ -$newline never -
- ^{fvInput (delButtons ! coord)} -
- ^{addWidget} - - ^{fvInput submitView} diff --git a/templates/widgets/occurrence/cell/except-no-occur.hamlet b/templates/widgets/occurrence/cell/except-no-occur.hamlet new file mode 100644 index 000000000..0019439a5 --- /dev/null +++ b/templates/widgets/occurrence/cell/except-no-occur.hamlet @@ -0,0 +1,2 @@ +$newline never +_{MsgExceptionKindNoOccur}: #{exceptTime'} diff --git a/templates/widgets/occurrence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occur.hamlet new file mode 100644 index 000000000..2d8147d8b --- /dev/null +++ b/templates/widgets/occurrence/cell/except-occur.hamlet @@ -0,0 +1,2 @@ +$newline never +_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'} diff --git a/test/Database.hs b/test/Database.hs index f339ee6d0..f59df7ec2 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -605,7 +605,7 @@ fillDb = do , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" , tutorialTime = Occurrences - { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs index b7af14fe9..1edc9baa2 100644 --- a/test/FoundationSpec.hs +++ b/test/FoundationSpec.hs @@ -38,6 +38,10 @@ instance Arbitrary TutorialR where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary ExamR where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary (Route UniWorX) where arbitrary = genericArbitrary shrink = genericShrink diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 833369af2..da1f578d0 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 @@ -147,7 +147,7 @@ instance Arbitrary AuthTag where shrink = genericShrink instance CoArbitrary AuthTag where coarbitrary = genericCoarbitrary - + instance Arbitrary AuthTagActive where arbitrary = AuthTagActive <$> arbitrary shrink = genericShrink @@ -176,7 +176,7 @@ instance Arbitrary AuthenticationMode where authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2) return $ AuthPWHash{..} ] - + shrink AuthLDAP = [] shrink (AuthPWHash _) = [AuthLDAP] @@ -195,18 +195,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