diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 9f3625c7e..8b60430d0 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -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 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f2e5c81b6..8b15af8b0 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 80f979ff3..86216a4ed 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 63867d4d4..31465c5f8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 18a4c473a..6728e11a2 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index d1c9d3e4b..cc16635d7 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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 diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 624b6cea4..fc4e88574 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -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 diff --git a/src/Handler/Utils/SheetType.hs b/src/Handler/Utils/SheetType.hs new file mode 100644 index 000000000..69885e759 --- /dev/null +++ b/src/Handler/Utils/SheetType.hs @@ -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") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3c5155842..808ad04af 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9b0c591f8..3bd7ebc45 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -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(..)) diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index 6ce7760f5..c7b4e910f 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -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) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 27025eed3..222b84a22 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 } diff --git a/src/Utils.hs b/src/Utils.hs index 8965c0009..0bd5a400d 100644 --- a/src/Utils.hs +++ b/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 -- ------------ diff --git a/templates/corrections.hamlet b/templates/corrections.hamlet index ae932745a..8dcaa38fb 100644 --- a/templates/corrections.hamlet +++ b/templates/corrections.hamlet @@ -1,5 +1,7 @@ -
+
^{table}