Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
Gregor Kleen
commit
dafb2389ba
2
.vscode/tasks.json
vendored
2
.vscode/tasks.json
vendored
@ -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
|
||||
|
||||
@ -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
|
||||
@ -97,7 +98,8 @@ 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)
|
||||
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
|
||||
(sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
@ -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
|
||||
@ -182,7 +185,7 @@ getSheetListR tid ssh csh = do
|
||||
in anchorCellM mkRoute $(widgetFile "widgets/rating")
|
||||
, 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
|
||||
@ -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)
|
||||
|
||||
@ -335,17 +335,17 @@ sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Han
|
||||
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
|
||||
where
|
||||
selOptions = Map.fromList
|
||||
[ ( Points', Points <$> maxPointsReq )
|
||||
[ ( Points', Points <$> maxPointsReq )
|
||||
, ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
|
||||
, ( PassBinary', pure PassBinary)
|
||||
]
|
||||
classify' :: SheetGrading -> SheetGrading'
|
||||
classify' = \case
|
||||
Points {} -> Points'
|
||||
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)
|
||||
|
||||
|
||||
|
||||
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")
|
||||
@ -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}
|
||||
@ -6,15 +6,16 @@ $maybe points <- submissionRatingPoints
|
||||
$case grading
|
||||
$of Points{..}
|
||||
_{MsgAchievedOf points maxPoints}
|
||||
$of PassPoints{}
|
||||
$of PassPoints{maxPoints}
|
||||
$if fromMaybe False (gradingPassed grading points)
|
||||
_{MsgPassed}
|
||||
_{MsgPassed}, _{MsgAchievedOf points maxPoints}
|
||||
$else
|
||||
_{MsgNotPassed}
|
||||
_{MsgNotPassed}, _{MsgAchievedOf points maxPoints}
|
||||
$of PassBinary
|
||||
$if fromMaybe False (gradingPassed grading points)
|
||||
_{MsgPassed}
|
||||
$else
|
||||
_{MsgNotPassed}
|
||||
, _{SheetTypeHeader sheetType}
|
||||
$nothing
|
||||
#{tickmarkS}
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
$# 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>
|
||||
<p>
|
||||
Gesamtpunktzahl #{display realPoints}
|
||||
$maybe nPts <- getSum <$> achievedPoints realGrades
|
||||
\ davon #{display nPts} erreicht
|
||||
@ -16,7 +16,7 @@ $with realGrades <- normalSummary <> bonusSummary
|
||||
\ #{textPercent $ realToFrac $ nPts / realPoints}
|
||||
\.
|
||||
$maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
|
||||
<li>
|
||||
<p>
|
||||
<em>Hinweis:
|
||||
\ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
|
||||
welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
|
||||
@ -27,7 +27,7 @@ $with realGrades <- normalSummary <> bonusSummary
|
||||
\.
|
||||
|
||||
$maybe reqPasses <- positiveSum (numGradePasses normalSummary)
|
||||
<li>
|
||||
<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.
|
||||
|
||||
|
||||
Reference in New Issue
Block a user