Merge branch 'master' into 205-klausuren
Fix tests
This commit is contained in:
Gregor Kleen
commit
b63d77ec7b
@ -1,5 +1,5 @@
|
||||
[Dolphin]
|
||||
Timestamp=2018,3,14,10,57,55
|
||||
Timestamp=2019,6,26,19,32,25
|
||||
Version=4
|
||||
|
||||
[Settings]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
]
|
||||
|
||||
@ -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")
|
||||
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
34
src/Utils.hs
34
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
|
||||
|
||||
@ -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 --
|
||||
------------------------------------------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -48,4 +48,6 @@ extra-deps:
|
||||
|
||||
- filepath-1.4.2
|
||||
|
||||
- haskell-src-exts-util-0.2.1.2
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
@ -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 .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
|
||||
<td .table__td>#{ciSubmissionsNr}
|
||||
$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>
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)}
|
||||
@ -1,5 +0,0 @@
|
||||
$newline never
|
||||
<td colspan=2>
|
||||
^{addWidget}
|
||||
<td>
|
||||
^{fvInput submitView}
|
||||
2
templates/widgets/occurrence/cell/except-no-occur.hamlet
Normal file
2
templates/widgets/occurrence/cell/except-no-occur.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
_{MsgExceptionKindNoOccur}: #{exceptTime'}
|
||||
2
templates/widgets/occurrence/cell/except-occur.hamlet
Normal file
2
templates/widgets/occurrence/cell/except-occur.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'}
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user