Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
Gregor Kleen
commit
dafb2389ba
4
.vscode/tasks.json
vendored
4
.vscode/tasks.json
vendored
@ -1,4 +1,4 @@
|
||||
{
|
||||
{
|
||||
"version": "2.0.0",
|
||||
"tasks": [
|
||||
{
|
||||
@ -11,7 +11,7 @@
|
||||
},
|
||||
"presentation": {
|
||||
"echo": true,
|
||||
"reveal": "silent",
|
||||
"reveal": "always",
|
||||
"focus": false,
|
||||
"panel": "dedicated",
|
||||
"showReuseMessage": false
|
||||
|
||||
@ -380,7 +380,9 @@ SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tsh
|
||||
SheetGradingPassBinary: Bestanden/Nicht Bestanden
|
||||
SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
|
||||
|
||||
SheetGradingCount': Anzahl
|
||||
SheetGradingPoints': Punkte
|
||||
SheetGradingPassing': Bestehen
|
||||
SheetGradingPassPoints': Bestehen nach Punkten
|
||||
SheetGradingPassBinary': Bestanden/Nicht bestanden
|
||||
|
||||
@ -388,7 +390,11 @@ SheetTypeBonus grading@SheetGrading: Bonus
|
||||
SheetTypeNormal grading@SheetGrading: Normal
|
||||
SheetTypeInformational grading@SheetGrading: Keine Wertung
|
||||
SheetTypeNotGraded: Unbewertet
|
||||
SheetTypeInfo: Bonus Blätter zählen, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
|
||||
SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
|
||||
SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
|
||||
SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
|
||||
SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter
|
||||
SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben
|
||||
|
||||
SheetTypeBonus': Bonus
|
||||
SheetTypeNormal': Normal
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
|
||||
|
||||
module Foundation where
|
||||
@ -144,7 +145,7 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
|
||||
pattern CSubmissionR tid ssh csh shn cid ptn
|
||||
= CSheetR tid ssh csh shn (SubmissionR cid ptn)
|
||||
|
||||
-- Messages
|
||||
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
|
||||
mkMessage "UniWorX" "messages/uniworx" "de"
|
||||
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
|
||||
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
|
||||
@ -224,6 +225,16 @@ instance RenderMessage UniWorX SheetType where
|
||||
newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
|
||||
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
|
||||
|
||||
newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
|
||||
deriving (Generic, Typeable)
|
||||
deriving newtype (Semigroup, Monoid, IsList)
|
||||
|
||||
instance RenderMessage UniWorX UniWorXMessages where
|
||||
renderMessage foundation ls (UniWorXMessages msgs) =
|
||||
intercalate " " $ map (renderMessage foundation ls) msgs
|
||||
|
||||
uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
|
||||
uniworxMessages = UniWorXMessages . map SomeMessage
|
||||
|
||||
-- Menus and Favourites
|
||||
data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary
|
||||
|
||||
@ -7,6 +7,7 @@ import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Submission
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.SheetType
|
||||
-- import Handler.Utils.Zip
|
||||
|
||||
import Utils.Lens
|
||||
@ -56,25 +57,33 @@ import Data.Foldable (foldrM)
|
||||
|
||||
|
||||
|
||||
type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
|
||||
(expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
|
||||
-> expr (E.Value Bool)
|
||||
|
||||
ratedBy :: Key User -> CorrectionsWhere
|
||||
ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
|
||||
courseIs :: Key Course -> CorrectionsWhere
|
||||
courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
|
||||
|
||||
sheetIs :: Key Sheet -> CorrectionsWhere
|
||||
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
|
||||
|
||||
submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
|
||||
submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
|
||||
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
|
||||
|
||||
correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
|
||||
correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ whereClause t
|
||||
return $ returnStatement t
|
||||
|
||||
-- Where Clauses
|
||||
ratedBy :: UserId -> CorrectionTableWhere
|
||||
ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
|
||||
courseIs :: CourseId -> CorrectionTableWhere
|
||||
courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid
|
||||
|
||||
sheetIs :: Key Sheet -> CorrectionTableWhere
|
||||
sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
|
||||
|
||||
submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
|
||||
submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
|
||||
|
||||
|
||||
-- Columns
|
||||
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
|
||||
@ -94,6 +103,10 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
shn = sheetName $ entityVal sheet
|
||||
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
|
||||
|
||||
colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty
|
||||
@ -116,7 +129,7 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult
|
||||
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
|
||||
csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
@ -138,6 +151,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
-- shn = sheetName
|
||||
|
||||
mkRoute = do
|
||||
cid <- encrypt subId
|
||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||
@ -176,23 +190,19 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
|
||||
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
|
||||
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
||||
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ whereClause (course,sheet,submission)
|
||||
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
)
|
||||
return (submission, sheet, crse, corrector)
|
||||
dbtSQLQuery = correctionsTableQuery whereClause
|
||||
(\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
|
||||
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
)
|
||||
in (submission, sheet, crse, corrector)
|
||||
)
|
||||
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
|
||||
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
|
||||
submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
|
||||
@ -200,7 +210,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
||||
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
|
||||
E.orderBy [E.asc $ user E.^. UserId]
|
||||
E.orderBy [E.asc $ user E.^. UserDisplayName]
|
||||
return (user, pseudonym E.?. SheetPseudonymPseudonym)
|
||||
let
|
||||
submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
|
||||
@ -231,6 +241,16 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
||||
, ( "assignedtime"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
|
||||
)
|
||||
, ( "submittors"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
|
||||
E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.orderBy [E.asc $ user E.^. UserDisplayName]
|
||||
E.limit 1
|
||||
return (user E.^. UserDisplayName)
|
||||
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList
|
||||
[ ( "term"
|
||||
@ -356,9 +376,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
||||
redirect currentRoute
|
||||
|
||||
gradingSummary <- runDB $ do
|
||||
let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
|
||||
points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
|
||||
-- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
|
||||
return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
|
||||
let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
||||
fmap toTypedContent . defaultLayout $ do
|
||||
setTitleI MsgCourseCorrectionsTitle
|
||||
$(widgetFile "corrections")
|
||||
|
||||
where
|
||||
authorizedToAssign :: SubmissionId -> DB Bool
|
||||
authorizedToAssign sId = do
|
||||
@ -642,7 +669,7 @@ postCorrectionsCreateR = do
|
||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||||
FormSuccess (sid, (pss, invalids)) -> do
|
||||
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet")
|
||||
|
||||
|
||||
runDB $ do
|
||||
Sheet{..} <- get404 sid
|
||||
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
||||
|
||||
@ -6,6 +6,7 @@ import System.FilePath (takeFileName)
|
||||
import Handler.Utils
|
||||
-- import Handler.Utils.Zip
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.SheetType
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
@ -41,7 +42,7 @@ import qualified Data.Map as Map
|
||||
|
||||
import Data.Map (Map, (!?))
|
||||
|
||||
import Data.Monoid (Sum(..), Any(..))
|
||||
import Data.Monoid (Any(..))
|
||||
|
||||
-- import Control.Lens
|
||||
import Utils.Lens
|
||||
@ -62,7 +63,7 @@ data SheetForm = SheetForm
|
||||
{ sfName :: SheetName
|
||||
, sfDescription :: Maybe Html
|
||||
, sfType :: SheetType
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: UTCTime
|
||||
, sfActiveTo :: UTCTime
|
||||
@ -97,8 +98,9 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType
|
||||
& setTooltip MsgSheetTypeInfo) (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
|
||||
(sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
||||
@ -118,7 +120,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<* submitButton
|
||||
return $ case result of
|
||||
FormSuccess sheetResult
|
||||
@ -137,7 +139,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
] ]
|
||||
|
||||
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid ssh csh = do
|
||||
getSheetListR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
@ -152,18 +154,19 @@ getSheetListR tid ssh csh = do
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return (sheet, lastSheetEdit sheet, submission)
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
||||
[ dbRow
|
||||
, sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
||||
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
||||
$ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty timeCell mEditTime
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom
|
||||
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveTo
|
||||
, sortable Nothing (i18nCell MsgSheetType)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
|
||||
, sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
|
||||
Nothing -> mempty
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
@ -172,7 +175,7 @@ getSheetListR tid ssh csh = do
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
|
||||
, sortable (Just "rating") (i18nCell MsgRating)
|
||||
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
|
||||
Nothing -> mempty
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
let mkCid = encrypt sid
|
||||
@ -180,15 +183,15 @@ getSheetListR tid ssh csh = do
|
||||
cid' <- mkCid
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
||||
in anchorCellM mkRoute $(widgetFile "widgets/rating")
|
||||
, sortable Nothing -- (Just "percent")
|
||||
, sortable Nothing -- (Just "percent")
|
||||
(i18nCell MsgRatingPercent)
|
||||
$ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of
|
||||
(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
|
||||
in textCell $ textPercent $ realToFrac percent
|
||||
_other -> mempty
|
||||
_other -> mempty
|
||||
]
|
||||
@ -197,8 +200,8 @@ getSheetListR tid ssh csh = do
|
||||
table <- runDB $ dbTableWidget' psValidator DBTable
|
||||
{ dbtSQLQuery = sheetData
|
||||
, dbtColonnade = sheetCol
|
||||
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
|
||||
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
|
||||
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
|
||||
-> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "name"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||
@ -228,7 +231,7 @@ getSheetListR tid ssh csh = do
|
||||
, dbtIdent = "sheets" :: Text
|
||||
}
|
||||
-- Collect summary over all Sheets, not just the ones shown due to pagination:
|
||||
SheetTypeSummary{..} <- do
|
||||
statistics <- gradeSummaryWidget MsgSheetGradingSummaryTitle <$> do
|
||||
rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
|
||||
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
||||
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
||||
@ -238,7 +241,6 @@ getSheetListR tid ssh csh = do
|
||||
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
|
||||
defaultLayout $ do
|
||||
$(widgetFile "sheetList")
|
||||
$(widgetFile "widgets/sheetTypeSummary")
|
||||
|
||||
data ButtonGeneratePseudonym = BtnGenerate
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
@ -398,7 +400,7 @@ getSheetNewR tid ssh csh = do
|
||||
{ sfName = stepTextCounterCI sheetName
|
||||
, sfDescription = sheetDescription
|
||||
, sfType = sheetType
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
|
||||
, sfActiveFrom = addOneWeek sheetActiveFrom
|
||||
, sfActiveTo = addOneWeek sheetActiveTo
|
||||
@ -431,7 +433,7 @@ getSEditR tid ssh csh shn = do
|
||||
{ sfName = sheetName
|
||||
, sfDescription = sheetDescription
|
||||
, sfType = sheetType
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfVisibleFrom = sheetVisibleFrom
|
||||
, sfActiveFrom = sheetActiveFrom
|
||||
, sfActiveTo = sheetActiveTo
|
||||
|
||||
@ -263,7 +263,7 @@ multiFileField permittedFiles' = Field{..}
|
||||
pVals <- lift permittedFiles'
|
||||
let
|
||||
decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
|
||||
decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
|
||||
decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
|
||||
yieldMany vals
|
||||
.| C.filter (/= unpackZips)
|
||||
.| C.map fromPathPiece .| C.catMaybes
|
||||
@ -288,7 +288,7 @@ multiFileField permittedFiles' = Field{..}
|
||||
let fuiChecked
|
||||
| Right sentVals' <- sentVals = fuiId' `elem` sentVals'
|
||||
| otherwise = True
|
||||
return FileUploadInfo{..}
|
||||
return FileUploadInfo{..}
|
||||
fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
|
||||
E.orderBy [E.asc $ file E.^. FileTitle]
|
||||
@ -303,13 +303,13 @@ multiFileField permittedFiles' = Field{..}
|
||||
|
||||
|
||||
data SheetGrading' = Points' | PassPoints' | PassBinary'
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
|
||||
instance Universe SheetGrading'
|
||||
instance Finite SheetGrading'
|
||||
|
||||
nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
|
||||
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
|
||||
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
|
||||
|
||||
|
||||
data SheetType' = Bonus' | Normal' | Informational' | NotGraded'
|
||||
@ -319,7 +319,7 @@ instance Universe SheetType'
|
||||
instance Finite SheetType'
|
||||
|
||||
nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
|
||||
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
|
||||
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
|
||||
|
||||
|
||||
data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
|
||||
@ -333,31 +333,31 @@ embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
|
||||
|
||||
sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
|
||||
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
|
||||
where
|
||||
selOptions = Map.fromList
|
||||
[ ( Points', Points <$> maxPointsReq )
|
||||
where
|
||||
selOptions = Map.fromList
|
||||
[ ( Points', Points <$> maxPointsReq )
|
||||
, ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
|
||||
, ( PassBinary', pure PassBinary)
|
||||
]
|
||||
classify' :: SheetGrading -> SheetGrading'
|
||||
classify' = \case
|
||||
Points {} -> Points'
|
||||
classify' :: SheetGrading -> SheetGrading'
|
||||
classify' = \case
|
||||
Points {} -> Points'
|
||||
PassPoints {} -> PassPoints'
|
||||
PassBinary {} -> PassBinary'
|
||||
|
||||
maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints)
|
||||
|
||||
maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints)
|
||||
passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
|
||||
|
||||
|
||||
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
|
||||
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
|
||||
where
|
||||
where
|
||||
selOptions = Map.fromList
|
||||
[ ( Bonus' , Bonus <$> gradingReq )
|
||||
, ( Normal', Normal <$> gradingReq )
|
||||
, ( Informational', Informational <$> gradingReq )
|
||||
, ( NotGraded', pure NotGraded )
|
||||
]
|
||||
]
|
||||
gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
|
||||
& setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
|
||||
|
||||
@ -440,8 +440,8 @@ utcTimeField = Field
|
||||
fieldTimeFormat :: String
|
||||
--fieldTimeFormat = "%e.%m.%y %k:%M"
|
||||
fieldTimeFormat = "%Y-%m-%dT%H:%M"
|
||||
|
||||
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
|
||||
|
||||
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
|
||||
readTime :: Text -> Either UniWorXMessage UTCTime
|
||||
readTime t =
|
||||
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
|
||||
@ -595,7 +595,7 @@ formResultModal res finalDest handler = maybeT_ $ do
|
||||
FormMissing -> mzero
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
|
||||
FormSuccess val -> lift . execWriterT $ handler val
|
||||
|
||||
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
if
|
||||
| isModal -> sendResponse $ toJSON messages
|
||||
|
||||
@ -51,7 +51,7 @@ instance Pretty x => Pretty (CI x) where
|
||||
pretty = pretty . CI.original
|
||||
|
||||
|
||||
instance Pretty SheetGrading where
|
||||
instance Pretty SheetGrading where
|
||||
pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String)
|
||||
pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
|
||||
pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
|
||||
@ -59,12 +59,12 @@ instance Pretty SheetGrading where
|
||||
|
||||
validateRating :: SheetType -> Rating' -> [RatingException]
|
||||
validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
|
||||
| rp < 0
|
||||
= [RatingNegative]
|
||||
| NotGraded <- ratingSheetType
|
||||
| rp < 0
|
||||
= [RatingNegative]
|
||||
| NotGraded <- ratingSheetType
|
||||
= [RatingNotExpected]
|
||||
| (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints
|
||||
, rp > maxPoints
|
||||
, rp > maxPoints
|
||||
= [RatingExceedsMax]
|
||||
| (Just PassBinary) <- ratingSheetType ^? _grading
|
||||
, not (rp == 0 || rp == 1)
|
||||
@ -98,7 +98,7 @@ getRating submissionId = runMaybeT $ do
|
||||
, E.unValue -> ratingComment
|
||||
, E.unValue -> ratingTime
|
||||
) ] <- lift query
|
||||
|
||||
|
||||
return Rating{ ratingValues = Rating'{..}, .. }
|
||||
|
||||
formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
|
||||
|
||||
39
src/Handler/Utils/SheetType.hs
Normal file
39
src/Handler/Utils/SheetType.hs
Normal file
@ -0,0 +1,39 @@
|
||||
module Handler.Utils.SheetType
|
||||
(
|
||||
gradeSummaryWidget
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Data.Monoid (Sum(..))
|
||||
import Utils.Lens hiding ((<.>))
|
||||
|
||||
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
||||
addBonusToPoints sts =
|
||||
sts & _normalSummary . _achievedPoints %~ maxBonusPts . addBonusPts
|
||||
& _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
|
||||
where
|
||||
bonusPoints = sts ^. _bonusSummary . _achievedPoints
|
||||
maxPoints = sts ^. _normalSummary . _sumGradePoints
|
||||
maxBonusPts = fmap $ min maxPoints
|
||||
addBonusPts = maybeAdd bonusPoints
|
||||
|
||||
bonusPasses = sts ^. _bonusSummary . _achievedPasses
|
||||
maxPasses = sts ^. _normalSummary . _numGradePasses
|
||||
maxBonusPass = fmap $ min maxPasses
|
||||
addBonusPass = maybeAdd bonusPasses
|
||||
|
||||
gradeSummaryWidget :: RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
|
||||
gradeSummaryWidget title sts =
|
||||
let SheetTypeSummary{..} = addBonusToPoints sts
|
||||
sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
|
||||
hasPassings = positiveSum $ numGradePasses sumSummaries
|
||||
hasPoints = positiveSum $ sumGradePoints sumSummaries
|
||||
rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow")
|
||||
| (sumHeader,summary) <-
|
||||
[ (MsgSheetTypeNormal' ,normalSummary)
|
||||
, (MsgSheetTypeBonus' ,bonusSummary)
|
||||
, (MsgSheetTypeInformational' ,informationalSummary)
|
||||
] ]
|
||||
in if 0 == numSheets sumSummaries
|
||||
then mempty
|
||||
else $(widgetFile "widgets/gradingSummary")
|
||||
@ -183,7 +183,7 @@ instance Default (PSValidator m x) where
|
||||
Just pi -> swap . (\act -> execRWS act pi def) $ do
|
||||
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
|
||||
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
|
||||
|
||||
|
||||
l <- asks piLimit
|
||||
case l of
|
||||
Just l'
|
||||
@ -258,7 +258,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
|
||||
|
||||
data DBCell m x :: *
|
||||
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
|
||||
|
||||
|
||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
-- | Format @DBTable@ when sort-circuiting
|
||||
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
|
||||
@ -284,7 +284,7 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
dbCell = iso
|
||||
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
|
||||
(uncurry WidgetCell)
|
||||
|
||||
|
||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
dbWidget _ _ = return . snd
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
@ -331,7 +331,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
dbCell = iso
|
||||
(\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
|
||||
(\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
|
||||
|
||||
|
||||
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
||||
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
||||
dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
|
||||
@ -353,10 +353,10 @@ addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragmen
|
||||
instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
|
||||
mempty = FormCell mempty (return mempty)
|
||||
(FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
|
||||
|
||||
|
||||
instance IsDBTable m a => IsString (DBCell m a) where
|
||||
fromString = cell . fromString
|
||||
|
||||
|
||||
|
||||
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
|
||||
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
|
||||
@ -378,7 +378,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
, fieldView = error "multiTextField: should not be rendered"
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
|
||||
piResult <- lift . runInputGetResult $ PaginationInput
|
||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
|
||||
@ -571,6 +571,7 @@ formCell genIndex genForm input = FormCell
|
||||
|
||||
-- Predefined colonnades
|
||||
|
||||
--Number column?
|
||||
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
|
||||
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
||||
|
||||
|
||||
@ -35,10 +35,12 @@ import Mail as Import
|
||||
import Data.Data as Import (Data)
|
||||
import Data.Typeable as Import (Typeable)
|
||||
import GHC.Generics as Import (Generic)
|
||||
import GHC.Exts as Import (IsList)
|
||||
|
||||
import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..))
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Semigroup)
|
||||
|
||||
import Control.Monad.Morph as Import (MFunctor(..))
|
||||
|
||||
|
||||
@ -2,7 +2,6 @@ module Model.Rating where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Model
|
||||
|
||||
-- import Data.Text (Text)
|
||||
import Data.Text.Encoding.Error (UnicodeException(..))
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
@ -135,10 +135,11 @@ gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
|
||||
gradingPassed (PassBinary {}) pts = Just $ pts /= 0
|
||||
|
||||
data SheetGradeSummary = SheetGradeSummary
|
||||
{ sumGradePoints :: Sum Points
|
||||
{ numSheets :: Sum Int
|
||||
, numGradePasses :: Sum Int
|
||||
, achievedPoints :: Maybe (Sum Points)
|
||||
, sumGradePoints :: Sum Points
|
||||
, achievedPasses :: Maybe (Sum Int)
|
||||
, achievedPoints :: Maybe (Sum Points)
|
||||
} deriving (Generic, Read, Show, Eq)
|
||||
|
||||
instance Monoid SheetGradeSummary where
|
||||
@ -146,18 +147,25 @@ instance Monoid SheetGradeSummary where
|
||||
mappend = mappenddefault
|
||||
|
||||
instance Semigroup SheetGradeSummary where
|
||||
(<>) = mappend -- remove for GHC > 8.4.x
|
||||
(<>) = mappend -- TODO: remove for GHC > 8.4.x
|
||||
|
||||
makeLenses_ ''SheetGradeSummary
|
||||
|
||||
sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
|
||||
sheetGradeSum gr (Just p) =
|
||||
let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p }
|
||||
in case gr of PassBinary -> baseSum
|
||||
_other -> baseSum { achievedPoints = Just $ Sum $ p }
|
||||
sheetGradeSum (Points {..}) Nothing = mempty { sumGradePoints = Sum maxPoints }
|
||||
sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints
|
||||
, numGradePasses = Sum 1 }
|
||||
sheetGradeSum (PassBinary) Nothing = mempty { numGradePasses = Sum 1 }
|
||||
|
||||
sheetGradeSum (Points {..}) Nothing = mempty { numSheets = Sum 1
|
||||
, sumGradePoints = Sum maxPoints
|
||||
}
|
||||
sheetGradeSum (PassPoints{..}) Nothing = mempty { numSheets = Sum 1
|
||||
, numGradePasses = Sum 1
|
||||
, sumGradePoints = Sum maxPoints
|
||||
}
|
||||
sheetGradeSum (PassBinary) Nothing = mempty { numSheets = Sum 1
|
||||
, numGradePasses = Sum 1
|
||||
}
|
||||
|
||||
data SheetType
|
||||
= Normal { grading :: SheetGrading }
|
||||
@ -174,19 +182,26 @@ deriveJSON defaultOptions
|
||||
derivePersistFieldJSON ''SheetType
|
||||
|
||||
data SheetTypeSummary = SheetTypeSummary
|
||||
{ normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary
|
||||
, numNotGraded :: Sum Int
|
||||
{ normalSummary
|
||||
, bonusSummary
|
||||
, informationalSummary :: SheetGradeSummary
|
||||
, numNotGraded :: Sum Int
|
||||
} deriving (Generic, Read, Show, Eq)
|
||||
|
||||
instance Monoid SheetTypeSummary where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
instance Semigroup SheetTypeSummary where
|
||||
(<>) = mappend -- TODO: remove for GHC > 8.4.x
|
||||
|
||||
makeLenses_ ''SheetTypeSummary
|
||||
|
||||
sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
|
||||
sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps }
|
||||
sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps }
|
||||
sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
|
||||
sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 }
|
||||
sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 }
|
||||
|
||||
data SheetGroup
|
||||
= Arbitrary { maxParticipants :: Natural }
|
||||
|
||||
11
src/Utils.hs
11
src/Utils.hs
@ -213,6 +213,9 @@ textPercent x = lz <> pack (show rx) <> "%"
|
||||
rx = fromIntegral (round' $ 1000.0*x) / 10.0
|
||||
lz = if rx < 10.0 then "0" else ""
|
||||
|
||||
textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
|
||||
textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole)
|
||||
|
||||
stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
|
||||
stepTextCounterCI = CI.map stepTextCounter
|
||||
|
||||
@ -317,14 +320,13 @@ toNothing = const Nothing
|
||||
toNothingS :: String -> Maybe b
|
||||
toNothingS = const Nothing
|
||||
|
||||
maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
|
||||
maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap
|
||||
maybeAdd (Just x) (Just y) = Just (x + y)
|
||||
maybeAdd Nothing y = y
|
||||
maybeAdd x Nothing = x
|
||||
|
||||
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
|
||||
maybeEmpty (Just x) f = f x
|
||||
maybeEmpty Nothing _ = mempty
|
||||
maybeEmpty = flip foldMap
|
||||
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
@ -339,7 +341,7 @@ maybePositive a | a > 0 = Just a
|
||||
| otherwise = Nothing
|
||||
|
||||
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
|
||||
positiveSum (Sum x) = maybePositive x
|
||||
positiveSum = maybePositive . getSum
|
||||
|
||||
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
|
||||
maybeM dft act mb = mb >>= maybe dft act
|
||||
@ -369,7 +371,6 @@ instance Ord a => Ord (NTop (Maybe a)) where
|
||||
compare (NTop (Just x)) (NTop (Just y)) = compare x y
|
||||
|
||||
|
||||
|
||||
------------
|
||||
-- Either --
|
||||
------------
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
<div .container>
|
||||
<section>
|
||||
<form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
|
||||
^{table}
|
||||
<button type=submit>
|
||||
_{MsgBtnSubmit}
|
||||
<section>
|
||||
^{statistics}
|
||||
@ -1 +1,4 @@
|
||||
^{table}
|
||||
<section>
|
||||
^{table}
|
||||
<section>
|
||||
^{statistics}
|
||||
@ -29,7 +29,7 @@
|
||||
var iconEl = document.createElement('DIV');
|
||||
var closeEl = document.createElement('DIV');
|
||||
var dataDecay = alertEl.dataset.decay;
|
||||
var autoDecay = 30;
|
||||
var autoDecay = 10;
|
||||
if (dataDecay) {
|
||||
autoDecay = parseInt(dataDecay, 10);
|
||||
}
|
||||
|
||||
30
templates/widgets/gradingSummary.hamlet
Normal file
30
templates/widgets/gradingSummary.hamlet
Normal file
@ -0,0 +1,30 @@
|
||||
$# Displays gradings Summary for various purposes
|
||||
$# --
|
||||
<div>
|
||||
<h3>_{title $ getSum $ numSheets $ sumSummaries}
|
||||
<table .table .table--striped>
|
||||
<tr .table__row .table__row--head>
|
||||
<th>
|
||||
$# empty cell for row headers
|
||||
$maybe _ <- hasPassings
|
||||
<th .table__th colspan=2>_{MsgSheetGradingPassing'}
|
||||
$maybe _ <- hasPoints
|
||||
<th .table__th colspan=2>_{MsgSheetGradingPoints'}
|
||||
<th .table__th>_{MsgSheetGradingCount'}
|
||||
$# Number of Sheet/Submissions used for calculating maximum passes/points
|
||||
$forall row <- rowWdgts
|
||||
^{row}
|
||||
$maybe nrNoGrade <- positiveSum $ numNotGraded
|
||||
<tr .table__row>
|
||||
<th .table__th>_{MsgSheetTypeNotGraded}
|
||||
$maybe _ <- hasPassings
|
||||
<td colspan=2>
|
||||
$maybe _ <- hasPoints
|
||||
<td .table__td colspan=2>
|
||||
<td .table__td>#{display nrNoGrade}
|
||||
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
|
||||
<p>_{MsgSheetTypeInfoBonus}
|
||||
$maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
|
||||
_{MsgSheetGradingBonusIncluded}
|
||||
$maybe _ <- positiveSum $ informationalSummary ^. _numSheets
|
||||
<p>_{MsgSheetTypeInfoNotGraded}
|
||||
33
templates/widgets/gradingSummaryRow.hamlet
Normal file
33
templates/widgets/gradingSummaryRow.hamlet
Normal file
@ -0,0 +1,33 @@
|
||||
$# Displays one row of the grading summary
|
||||
$# Expects several variables:
|
||||
$# hasPassing :: Maybe Int -- Should Passing be displayed?
|
||||
$# hasPoints :: Maybe Poibts -- Should Points be displayed?
|
||||
$# summary :: SheetGradeSummary -- summary to display
|
||||
$# sumHeader :: UniWorXMessage -- row header
|
||||
$#
|
||||
$maybe nrSheets <- positiveSum $ summary ^. _numSheets
|
||||
<tr .table__row >
|
||||
<th .table__th>_{sumHeader}
|
||||
$maybe _ <- hasPassings
|
||||
$with Sum pmax <- summary ^. _numGradePasses
|
||||
$maybe Sum pacv <- summary ^. _achievedPasses
|
||||
<td .table__td>
|
||||
$if pmax /= 0
|
||||
#{textPercentInt pacv pmax}
|
||||
<td .table__td>
|
||||
#{display pacv} / #{display pmax}
|
||||
$nothing
|
||||
<td .table__td colspan=2>
|
||||
#{display pmax }
|
||||
$maybe _ <- hasPoints
|
||||
$with Sum pmax <- summary ^. _sumGradePoints
|
||||
$maybe Sum pacv <- summary ^. _achievedPoints
|
||||
<td .table__td>
|
||||
$if pmax /= 0
|
||||
#{textPercent $ realToFrac $ pacv / pmax}
|
||||
<td .table__td>
|
||||
#{display pacv} / #{display pmax}
|
||||
$nothing
|
||||
<td .table__td colspan=2>
|
||||
#{display pmax }
|
||||
<td .table__td>#{display nrSheets}
|
||||
@ -3,18 +3,19 @@ $# submissionRatingPoints :: Maybe points
|
||||
|
||||
$maybe points <- submissionRatingPoints
|
||||
$maybe grading <- preview _grading sheetType
|
||||
$case grading
|
||||
$case grading
|
||||
$of Points{..}
|
||||
_{MsgAchievedOf points maxPoints}
|
||||
$of PassPoints{}
|
||||
$if fromMaybe False (gradingPassed grading points)
|
||||
_{MsgPassed}
|
||||
$else
|
||||
_{MsgNotPassed}
|
||||
$of PassBinary
|
||||
_{MsgAchievedOf points maxPoints}
|
||||
$of PassPoints{maxPoints}
|
||||
$if fromMaybe False (gradingPassed grading points)
|
||||
_{MsgPassed}, _{MsgAchievedOf points maxPoints}
|
||||
$else
|
||||
_{MsgNotPassed}, _{MsgAchievedOf points maxPoints}
|
||||
$of PassBinary
|
||||
$if fromMaybe False (gradingPassed grading points)
|
||||
_{MsgPassed}
|
||||
$else
|
||||
_{MsgNotPassed}
|
||||
, _{SheetTypeHeader sheetType}
|
||||
$nothing
|
||||
#{tickmarkS}
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
$with realGrades <- normalSummary <> bonusSummary
|
||||
$# DEPRECATED IN FAVOUR OF widgets/gradingSummary.hamlet DO NOT USE !!!
|
||||
$with realGrades <- normalSummary <> bonusSummary
|
||||
$# $with allGrades <- realGrades <> informationalSummary
|
||||
<div>
|
||||
<ul>
|
||||
$maybe realPoints <- positiveSum (sumGradePoints realGrades)
|
||||
<li>
|
||||
$maybe realPoints <- positiveSum (sumGradePoints realGrades)
|
||||
<p>
|
||||
Gesamtpunktzahl #{display realPoints}
|
||||
$maybe nPts <- getSum <$> achievedPoints realGrades
|
||||
\ davon #{display nPts} erreicht
|
||||
@ -13,21 +13,21 @@ $with realGrades <- normalSummary <> bonusSummary
|
||||
von #{display achievedBonus} erreichbaren #
|
||||
Bonuspunkten)
|
||||
$if realPoints /= 0
|
||||
\ #{textPercent $ realToFrac $ nPts / realPoints}
|
||||
\ #{textPercent $ realToFrac $ nPts / realPoints}
|
||||
\.
|
||||
$maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
|
||||
<li>
|
||||
<em>Hinweis:
|
||||
<p>
|
||||
<em>Hinweis:
|
||||
\ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
|
||||
welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
|
||||
$maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
|
||||
, davon wurden #{display achievedFakes} erreicht
|
||||
$if fakePoints /= 0
|
||||
\ #{textPercent $ realToFrac $ achievedFakes / fakePoints}
|
||||
\ #{textPercent $ realToFrac $ achievedFakes / fakePoints}
|
||||
\.
|
||||
|
||||
$maybe reqPasses <- positiveSum (numGradePasses normalSummary)
|
||||
<li>
|
||||
$maybe reqPasses <- positiveSum (numGradePasses normalSummary)
|
||||
<p>
|
||||
Aufgaben zum Bestehen: #{display reqPasses}
|
||||
$maybe passed <- getSum <$> achievedPasses realGrades
|
||||
\ davon #{display passed} bestanden
|
||||
@ -36,6 +36,6 @@ $with realGrades <- normalSummary <> bonusSummary
|
||||
\.
|
||||
|
||||
$maybe noGradeSheets <- positiveSum numNotGraded
|
||||
<li>
|
||||
<p>
|
||||
#{display noGradeSheets} unbewertete Aufgabenblätter.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user