Merge branch 'master' into 205-klausuren

Fix tests

.directory

@@ -1,5 +1,5 @@
 [Dolphin]
-Timestamp=2018,3,14,10,57,55
+Timestamp=2019,6,26,19,32,25
 Version=4
 
 [Settings]

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

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)

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

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 <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+  assignHandler tid ssh csh cid []
-    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
@@ -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
+{- TODO: Feature:
-assignHandler' :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
+  make distivt buttons for each sheet, so that users see which sheet will be assigned.
-assignHandler' tid ssh csh _cid rawSids = do
+  Currently this information is available within the page heading!
-  -- 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
 
-
+  Stub:
-{- 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)
+    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
+      getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad
-        | (Just load) <- Map.lookup shn sheetLoad
+                     = showCompactCorrectorLoad load CorrectorNormal
-        = "Σ" <> showCompactCorrectorLoad load CorrectorNormal
+      getLoadSum  _  = mempty
-      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")

src/Handler/Health.hs

@@ -63,7 +63,7 @@ getHealthR = do
                     <dd .deflist__dd>#{boolSymbol passed}
                   $of HealthLDAPAdmins (Just found)
                     <dt .deflist__dt>_{MsgHealthLDAPAdmins}
-                    <dd .deflist__dd>#{textPercent found}
+                    <dd .deflist__dd>#{textPercent found 1}
                   $of HealthSMTPConnect (Just passed)
                     <dt .deflist__dt>_{MsgHealthSMTPConnect}
                     <dd .deflist__dd>#{boolSymbol passed}
@@ -80,7 +80,7 @@ getInstanceR = do
   instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID
 
   setWeakEtagHashable (clusterId, instanceId)
-  
+
   selectRep $ do
     provideRep $
       siteLayoutMsg MsgInstanceIdentification $ do

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

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

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 ->
+                    | maxPoints /= 0 -> textCell $ textPercent sPoints maxPoints
-                        let percent = sPoints / maxPoints
-                        in textCell $ textPercent $ realToFrac percent
                   _other -> mempty
               _other -> mempty
       ]

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

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")
+          $(widgetFile "widgets/occurrence/cell/except-occur")
-        ExceptNoOccurr{..} -> do
+        ExceptNoOccur{..} -> do
           exceptTime' <- formatTime SelFormatDateTime exceptTime
-          $(widgetFile "widgets/occurrence/cell/except-no-occurr")
+          $(widgetFile "widgets/occurrence/cell/except-no-occur")
   $(widgetFile "widgets/occurrence/cell")

src/Model/Types/DateTime.hs

@@ -166,14 +166,14 @@ deriveJSON defaultOptions
   , sumEncoding = TaggedObject "repeat" "schedule"
   } ''OccurrenceSchedule
 
-data OccurrenceException = ExceptOccurr
+data OccurrenceException = ExceptOccur
-                           { exceptDay   :: Day
+                          { exceptDay   :: Day
-                           , exceptStart :: TimeOfDay
+                          , exceptStart :: TimeOfDay
-                           , exceptEnd   :: TimeOfDay
+                          , exceptEnd   :: TimeOfDay
-                           }
+                          }
-                         | ExceptNoOccurr
+                        | ExceptNoOccur
-                           { exceptTime  :: LocalTime
+                          { exceptTime  :: LocalTime
-                           }
+                          }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions

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?
+-- | Convert `part` and `whole` into percentage including symbol
-textPercent x = lz <> pack (show rx) <> "%"
+--   showing trailing zeroes and to decimal digits
- where
+textPercent :: Real a => a -> a -> Text
-   rx :: Centi
+textPercent = textPercent' False 2
-   rx = realToFrac (x * 100)
+
-   lz = if rx < 10.0 then "0" else ""
+-- | 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

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

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

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

stack.yaml

@@ -48,4 +48,6 @@ extra-deps:
 
   - filepath-1.4.2
 
+  - haskell-src-exts-util-0.2.1.2
+
 resolver: lts-10.5

templates/corrections-overview.hamlet

@@ -45,7 +45,7 @@
     <tr .table__row .table__row--head>
       <th .table__th rowspan=2>_{MsgCorrector}
       <th .table__th colspan=2>_{MsgGenericAll}
-      <th .table__th>_{MsgCorProportion}
+      <th .table__th rowspan=2>_{MsgCorDeficitProportion}
       <th .table__th colspan=3>_{MsgCorrectionTime}
       $forall shn <- sheetNames
         <th .table__th colspan=5>#{shn}
@@ -53,7 +53,6 @@
     <tr .table__row .table__row--head>
       <th .table__th>_{MsgNrSubmissionsTotal}
       <th .table__th>_{MsgNrSubmissionsNotCorrected}
-      <th .table__th>_{MsgCorDeficit}
       <th .table__th>_{MsgGenericMin}
       <th .table__th>_{MsgGenericAvg}
       <th .table__th>_{MsgGenericMax}
@@ -63,24 +62,33 @@
         <th .table__th>_{MsgGenericNumChange}
         <th .table__th>_{MsgNrSubmissionsNotCorrectedShort}
         <th .table__th>_{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
         <tr .table__row>
           <td .table__td>^{nameW}
-          <td .table__td>#{ciSubmissions}
+          <td .table__td>#{ciSubmissionsNr}
-          <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
+            $with total <- ciSubmissions corrMapSum
+              $if total > 0
+                \ (#{textPercent' True 0 ciSubmissionsNr total})
+          <td .table__td .heated style="--hotness: #{heat ciSubmissionsNr ciCorrected}">#{ciSubmissionsNr - ciCorrected}
           <td .table__td>
               $maybe deficit <- getCorrDeficit ciCorrector
                 #{display deficit}
           <td .table__td>#{showDiffDays ciMin}
           <td .table__td>#{showAvgsDays ciTot ciCorrected}
           <td .table__td>#{showDiffDays ciMax}
-          $forall shn <- sheetNames
+          $forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- Map.toList sheetMap
             <td .table__td>
               $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
               <td .table__td>#{ciSubmissions}
+                $if sheetSubmissionsNr > 0
+                  \ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr})
               $maybe nrNew <- getCorrNewAssignment ciCorrector shn
                 $# <td .table__td>#{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap`
                 <td .table__td .alert-info>(+#{nrNew})
@@ -95,9 +103,17 @@
               <td .table__td>
     $if 0 < length sheetNames
       <tr .table__row>
-        <td colspan=6>
+        <td .table__th>Σ
+        $with ciSubmissionsNr <- ciSubmissions corrMapSum
+          $with ciCorrectedNr <- ciCorrected   corrMapSum
+            <td .table__th>#{ciSubmissionsNr}
+            <td .table__td .heated style="--hotness: #{heat ciSubmissionsNr ciCorrectedNr}">#{ciSubmissionsNr - ciCorrectedNr}
+        <td .table__th>#{ciCorrected   corrMapSum}
+        <td .table__th>#{showDiffDays (ciMin corrMapSum)}
+        <td .table__th>#{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)}
+        <td .table__th>#{showDiffDays (ciMax corrMapSum)}
         $forall shn <- sheetNames
-          <td .table__td>#{getLoadSum shn}
+          <td .table__th>#{getLoadSum shn}
           <td .table__td colspan=4>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
   ^{btnWdgt}
  <div>

templates/widgets/grading-summary/grading-summary-row.hamlet

@@ -19,7 +19,7 @@ $#
             $with Sum pacv <- summary ^. _achievedPasses
               <td .table__td>
                 $if pmax > 0
-                  #{textPercentInt pacv pmax}
+                  #{textPercent pacv pmax}
               <td .table__td>
                 #{display pacv} / #{display pmax}
           $else
@@ -35,7 +35,7 @@ $#
           $with Sum pacv <- summary ^. _achievedPoints
             <td .table__td>
               $if pmax > 0
-                #{textPercent $ realToFrac $ pacv / pmax}
+                #{textPercent pacv pmax}
             <td .table__td>
               #{display pacv} / #{display pmax}
               $if ((summary ^. _numMarkedPoints) /= (summary ^. _numSheets))

templates/widgets/occurence/form/except-layout.hamlet

@@ -1,11 +0,0 @@
-$newline never
-<table>
-  <tbody>
-    $forall coord <- review liveCoords lLength
-      <tr .massinput__cell>
-        ^{cellWdgts ! coord}
-        <td>
-          ^{fvInput (delButtons ! coord)}
-  <tfoot>
-    <tr .massinput__cell.massinput__cell--add>
-      ^{addWdgts ! (0, 0)}

templates/widgets/occurence/form/scheduled-add.hamlet

@@ -1,5 +0,0 @@
-$newline never
-<td colspan=2>
-  ^{addWidget}
-<td>
-  ^{fvInput submitView}

templates/widgets/occurrence/cell/except-no-occur.hamlet

@@ -0,0 +1,2 @@
+$newline never
+_{MsgExceptionKindNoOccur}: #{exceptTime'}

templates/widgets/occurrence/cell/except-occur.hamlet

@@ -0,0 +1,2 @@
+$newline never
+_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'}

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"

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

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