fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Sorting Corrections and UniWorXMessages Monoid

Browse Source
This commit is contained in:
SJost 2018-12-05 11:41:25 +01:00
parent aa455d2bdd
commit 17ea26430f
6 changed files with 35 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Foundation.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
module Foundation where
@ -222,6 +223,12 @@ 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) = foldMap (renderMessage foundation ls) msgs
-- Menus and Favourites
data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary

14
src/Handler/Corrections.hs
View File

@ -128,7 +128,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
@ -209,7 +209,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
@ -240,6 +240,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"

24
src/Handler/Sheet.hs
View File

@ -152,19 +152,19 @@ getSheetListR tid ssh csh = do
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet, lastSheetEdit sheet, submission)
sheetCol = widgetColonnade . mconcat $
[ -- TODO: dbRow add numbers
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
@ -173,7 +173,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
@ -183,7 +183,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
@ -198,8 +198,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

2
src/Handler/Utils/Rating.hs
View File

@ -219,7 +219,7 @@ addBonusToPoints sts =
maxBonusPass = fmap $ min maxPasses
addBonusPass = maybeAdd bonusPasses
gradeSummaryWidget :: (Int -> UniWorXMessage) -> SheetTypeSummary -> Widget
gradeSummaryWidget :: RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
gradeSummaryWidget title sts =
let SheetTypeSummary{..} = addBonusToPoints sts
sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)

2
src/Import/NoFoundation.hs
View File

@ -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
templates/standalone/alerts.julius
View File

@ -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);
}