Summary shown for all submission, but mislabelled
This commit is contained in:
SJost
parent
dbb69e1817
commit
fed70610f0
@ -56,25 +56,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, _, _) } ->
|
||||
@ -176,23 +184,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 -> _ -> Handler (DBResult m x)
|
||||
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (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
|
||||
@ -356,9 +360,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
||||
redirect currentRoute
|
||||
|
||||
SheetTypeSummary{..} <- 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 = $(widgetFile "widgets/sheetTypeSummary")
|
||||
fmap toTypedContent . defaultLayout $ do
|
||||
setTitleI MsgCourseCorrectionsTitle
|
||||
$(widgetFile "corrections")
|
||||
|
||||
where
|
||||
authorizedToAssign :: SubmissionId -> DB Bool
|
||||
authorizedToAssign sId = do
|
||||
@ -639,7 +650,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)
|
||||
|
||||
@ -62,7 +62,7 @@ data SheetForm = SheetForm
|
||||
{ sfName :: SheetName
|
||||
, sfDescription :: Maybe Html
|
||||
, sfType :: SheetType
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: UTCTime
|
||||
, sfActiveTo :: UTCTime
|
||||
@ -98,7 +98,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType
|
||||
& setTooltip MsgSheetTypeInfo) (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
||||
@ -118,7 +118,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 +137,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
|
||||
@ -180,7 +180,7 @@ 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
|
||||
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
|
||||
@ -188,7 +188,7 @@ getSheetListR tid ssh csh = do
|
||||
Just maxPoints
|
||||
| maxPoints /= 0 ->
|
||||
let percent = sPoints / maxPoints
|
||||
in textCell $ textPercent $ realToFrac percent
|
||||
in textCell $ textPercent $ realToFrac percent
|
||||
_other -> mempty
|
||||
_other -> mempty
|
||||
]
|
||||
@ -236,9 +236,9 @@ getSheetListR tid ssh csh = do
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
|
||||
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
|
||||
let statistics = $(widgetFile "widgets/sheetTypeSummary")
|
||||
defaultLayout $ do
|
||||
$(widgetFile "sheetList")
|
||||
$(widgetFile "widgets/sheetTypeSummary")
|
||||
|
||||
data ButtonGeneratePseudonym = BtnGenerate
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
@ -398,7 +398,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 +431,7 @@ getSEditR tid ssh csh shn = do
|
||||
{ sfName = sheetName
|
||||
, sfDescription = sheetDescription
|
||||
, sfType = sheetType
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfVisibleFrom = sheetVisibleFrom
|
||||
, sfActiveFrom = sheetActiveFrom
|
||||
, sfActiveTo = sheetActiveTo
|
||||
|
||||
@ -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}
|
||||
@ -1,9 +1,8 @@
|
||||
$with realGrades <- normalSummary <> bonusSummary
|
||||
$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 +12,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 +35,6 @@ $with realGrades <- normalSummary <> bonusSummary
|
||||
\.
|
||||
|
||||
$maybe noGradeSheets <- positiveSum numNotGraded
|
||||
<li>
|
||||
<p>
|
||||
#{display noGradeSheets} unbewertete Aufgabenblätter.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user