From eff7875c1c0cb2226283c14aac6f9cf85e915672 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 28 Oct 2018 19:11:40 +0100 Subject: [PATCH 01/13] Cleanup language extensions --- package.yaml | 48 ++++++++++++++ src/Application.hs | 14 +---- src/Auth/Dummy.hs | 8 --- src/Auth/LDAP.hs | 11 ---- src/Auth/PWHash.hs | 10 --- src/Cron.hs | 9 --- src/Cron/Types.hs | 5 -- src/CryptoID.hs | 8 --- src/CryptoID/TH.hs | 4 -- src/Data/CaseInsensitive/Instances.hs | 7 +-- .../Universe/Instances/Reverse/Hashable.hs | 3 - src/Data/Universe/Instances/Reverse/JSON.hs | 3 - src/Foundation.hs | 15 +---- src/Handler/Admin.hs | 11 ---- src/Handler/Common.hs | 5 -- src/Handler/Corrections.hs | 17 ----- src/Handler/Course.hs | 15 ----- src/Handler/CryptoIDDispatch.hs | 16 +---- src/Handler/Home.hs | 13 ---- src/Handler/Profile.hs | 14 ----- src/Handler/School.hs | 15 ----- src/Handler/Sheet.hs | 17 ----- src/Handler/Submission.hs | 35 +++-------- src/Handler/SystemMessage.hs | 14 ----- src/Handler/Term.hs | 63 ++++++++----------- src/Handler/Users.hs | 8 --- src/Handler/Utils.hs | 7 --- src/Handler/Utils/DateTime.hs | 7 --- src/Handler/Utils/Form.hs | 14 ----- src/Handler/Utils/Form/Types.hs | 2 - src/Handler/Utils/Mail.hs | 8 --- src/Handler/Utils/Rating.hs | 12 ---- src/Handler/Utils/Sheet.hs | 10 --- src/Handler/Utils/StudyFeatures.hs | 4 -- src/Handler/Utils/Submission.hs | 16 ----- src/Handler/Utils/Submission/TH.hs | 7 --- src/Handler/Utils/Table.hs | 5 -- src/Handler/Utils/Table/Cells.hs | 7 --- src/Handler/Utils/Table/Pagination.hs | 22 +------ src/Handler/Utils/Table/Pagination/Types.hs | 6 -- src/Handler/Utils/Templates.hs | 2 - src/Handler/Utils/Zip.hs | 4 -- src/Import/NoFoundation.hs | 3 +- src/Jobs.hs | 17 +---- src/Jobs/Crontab.hs | 8 --- src/Jobs/Handler/HelpRequest.hs | 6 -- src/Jobs/Handler/QueueNotification.hs | 5 -- src/Jobs/Handler/SendNotification.hs | 5 -- .../SendNotification/CorrectionsAssigned.hs | 7 --- .../Handler/SendNotification/SheetActive.hs | 7 --- .../Handler/SendNotification/SheetInactive.hs | 9 +-- .../SendNotification/SubmissionRated.hs | 7 --- src/Jobs/Handler/SendTestEmail.hs | 6 -- src/Jobs/Handler/SetLogSettings.hs | 3 - src/Jobs/Queue.hs | 4 -- src/Jobs/TH.hs | 29 --------- src/Jobs/Types.hs | 6 -- src/Mail.hs | 19 +----- src/Model.hs | 19 ------ src/Model/Migration.hs | 8 --- src/Model/Migration/Version.hs | 7 --- src/Model/Types.hs | 16 +---- src/Model/Types/JSON.hs | 4 -- src/Model/Types/Wordlist.hs | 6 -- src/Settings.hs | 16 +---- src/Settings/Cluster.hs | 8 --- src/Settings/StaticFiles.hs | 3 - src/Utils.hs | 9 --- src/Utils/DB.hs | 5 -- src/Utils/DateTime.hs | 13 +--- src/Utils/Form.hs | 15 ----- src/Utils/Lang.hs | 4 -- src/Utils/Lens.hs | 5 -- src/Utils/Message.hs | 7 --- src/Utils/PathPiece.hs | 3 - src/Utils/Sql.hs | 8 --- src/Utils/SystemMessage.hs | 4 -- src/Utils/TH.hs | 19 ++++-- 78 files changed, 114 insertions(+), 727 deletions(-) delete mode 100644 src/Jobs/TH.hs diff --git a/package.yaml b/package.yaml index 44695edb0..246f6bcf3 100644 --- a/package.yaml +++ b/package.yaml @@ -111,6 +111,54 @@ dependencies: - mmorph - clientsession +other-extensions: + - GeneralizedNewtypeDeriving + - IncoherentInstances + - OverloadedLists + - UndecidableInstances + +default-extensions: + - OverloadedStrings + - PartialTypeSignatures + - ScopedTypeVariables + - TemplateHaskell + - QuasiQuotes + - CPP + - TypeSynonymInstances + - KindSignatures + - ConstraintKinds + - ViewPatterns + - TypeOperators + - TupleSections + - TypeFamilies + - GADTs + - StandaloneDeriving + - RecordWildCards + - RankNTypes + - PatternGuards + - PatternSynonyms + - ParallelListComp + - NumDecimals + - MultiWayIf + - NamedFieldPuns + - NoImplicitPrelude + - LambdaCase + - MultiParamTypeClasses + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - EmptyDataDecls + - ExistentialQuantification + - DefaultSignatures + - DeriveDataTypeable + - DeriveGeneric + - DeriveLift + - DeriveFunctor + - DerivingStrategies + - DataKinds + - BinaryLiterals + - PolyKinds + # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: diff --git a/src/Application.hs b/src/Application.hs index 0e7c7e211..3757d98f7 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,15 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Application ( getApplicationDev, getAppDevSettings , appMain @@ -29,7 +19,7 @@ module Application import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool) -import Import hiding (Proxy) +import Import import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 809db8647..df4ab5e40 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , TemplateHaskell - , FlexibleContexts - , TypeFamilies - , OverloadedStrings - #-} - module Auth.Dummy ( dummyLogin , DummyMessage(..) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 32c185519..2b053ce05 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,14 +1,3 @@ -{-# LANGUAGE RecordWildCards - , OverloadedStrings - , TemplateHaskell - , ViewPatterns - , TypeFamilies - , FlexibleContexts - , FlexibleInstances - , NoImplicitPrelude - , ScopedTypeVariables - #-} - module Auth.LDAP ( campusLogin , CampusUserException(..) diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index ba7198710..3efad0d32 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , QuasiQuotes - , TemplateHaskell - , ViewPatterns - , RecordWildCards - , OverloadedStrings - , FlexibleContexts - , TypeFamilies - #-} - module Auth.PWHash ( hashLogin , PWHashMessage(..) diff --git a/src/Cron.hs b/src/Cron.hs index 2620aec12..cb2d9a338 100644 --- a/src/Cron.hs +++ b/src/Cron.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , PatternGuards - , ViewPatterns - , DeriveFunctor - , TemplateHaskell - , NamedFieldPuns - #-} - module Cron ( CronNextMatch(..) , nextCronMatch diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs index fa95477f0..ab3e92972 100644 --- a/src/Cron/Types.hs +++ b/src/Cron/Types.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , DuplicateRecordFields - #-} - module Cron.Types ( Cron(..), Crontab , CronMatch(..) diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 58f68171e..6d4163982 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module CryptoID diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index 23122dadf..589c30637 100644 --- a/src/CryptoID/TH.hs +++ b/src/CryptoID/TH.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - module CryptoID.TH where import ClassyPrelude diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index ea5253f44..214283124 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.CaseInsensitive.Instances - () where + ( + ) where import ClassyPrelude.Yesod diff --git a/src/Data/Universe/Instances/Reverse/Hashable.hs b/src/Data/Universe/Instances/Reverse/Hashable.hs index e7459f613..d264fa41f 100644 --- a/src/Data/Universe/Instances/Reverse/Hashable.hs +++ b/src/Data/Universe/Instances/Reverse/Hashable.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , ScopedTypeVariables - #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Universe.Instances.Reverse.Hashable diff --git a/src/Data/Universe/Instances/Reverse/JSON.hs b/src/Data/Universe/Instances/Reverse/JSON.hs index 60b7ba6ae..14c7d04fa 100644 --- a/src/Data/Universe/Instances/Reverse/JSON.hs +++ b/src/Data/Universe/Instances/Reverse/JSON.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , ScopedTypeVariables - #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Universe.Instances.Reverse.JSON diff --git a/src/Foundation.hs b/src/Foundation.hs index 78ff9dc21..10de66a02 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,17 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternGuards, MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} module Foundation where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 46d65d29f..50b1963e7 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,14 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - module Handler.Admin where import Import diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 2119bfb06..390b041e1 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -- | Common handler functions. module Handler.Common where diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 9814f6d75..c1961857e 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1,20 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiWayIf, LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} - module Handler.Corrections where import Import diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 044f9b391..c9262a2b6 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,18 +1,3 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - module Handler.Course where import Import hiding (catMaybes) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 9a744f208..54c2ec760 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -1,23 +1,9 @@ -{-# LANGUAGE NoImplicitPrelude - , DataKinds - , KindSignatures - , TypeFamilies - , FlexibleInstances - , TypeOperators - , RankNTypes - , PolyKinds - , RecordWildCards - , MultiParamTypeClasses - , ScopedTypeVariables - , ViewPatterns - #-} - module Handler.CryptoIDDispatch ( getCryptoUUIDDispatchR , getCryptoFileNameDispatchR ) where -import Import hiding (Proxy) +import Import import Data.Proxy diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 458e3d766..8c93c4a17 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -1,16 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PartialTypeSignatures #-} - module Handler.Home where import Import diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 86e03d26e..3b16c186d 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1,17 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiWayIf, LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} - module Handler.Profile where import Import diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 9952a682d..92f0d2ec0 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -1,18 +1,3 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - module Handler.School where import Import diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e001b3a84..6150a1d54 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,20 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiWayIf, LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NamedFieldPuns #-} - module Handler.Sheet where import Import diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 5055f6f26..25cac807d 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -1,21 +1,3 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE MultiWayIf #-} - module Handler.Submission where import Import hiding (joinPath) @@ -314,14 +296,15 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do , dbtProj = return . dbrOutput , dbtStyle = def , dbtIdent = "files" :: Text - , dbtSorting = [ ( "path" - , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] - ) - , ( "time" - , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) - ) - ] - , dbtFilter = [] + , dbtSorting = Map.fromList + [ ( "path" + , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] + ) + , ( "time" + , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) + ) + ] + , dbtFilter = Map.empty } mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 801b0b194..487b79331 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -1,17 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , TemplateHaskell - , NamedFieldPuns - , RecordWildCards - , OverloadedStrings - , TypeFamilies - , ViewPatterns - , FlexibleContexts - , LambdaCase - , MultiParamTypeClasses - , QuasiQuotes - #-} - module Handler.SystemMessage where import Import diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 1720eec1f..611a4cc9a 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -1,19 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude - , OverloadedStrings - , OverloadedLists - , RecordWildCards - , TemplateHaskell - , QuasiQuotes - , MultiParamTypeClasses - , TypeFamilies - , FlexibleContexts - , PartialTypeSignatures - #-} - module Handler.Term where import Import import Handler.Utils +import qualified Data.Map as Map -- import qualified Data.Text as T import Yesod.Form.Bootstrap3 @@ -111,30 +100,32 @@ getTermShowR = do { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms , dbtProj = return . dbrOutput - , dbtSorting = [ ( "start" - , SortColumn $ \term -> term E.^. TermStart - ) - , ( "end" - , SortColumn $ \term -> term E.^. TermEnd - ) - , ( "lecture-start" - , SortColumn $ \term -> term E.^. TermLectureStart - ) - , ( "lecture-end" - , SortColumn $ \term -> term E.^. TermLectureEnd - ) - ] - , dbtFilter = [ ( "active" - , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool)) - ) - , ( "course" - , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are - [] -> E.val True :: E.SqlExpr (E.Value Bool) - cshs -> E.exists . E.from $ \course -> do - E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId - E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs - ) - ] + , dbtSorting = Map.fromList + [ ( "start" + , SortColumn $ \term -> term E.^. TermStart + ) + , ( "end" + , SortColumn $ \term -> term E.^. TermEnd + ) + , ( "lecture-start" + , SortColumn $ \term -> term E.^. TermLectureStart + ) + , ( "lecture-end" + , SortColumn $ \term -> term E.^. TermLectureEnd + ) + ] + , dbtFilter = Map.fromList + [ ( "active" + , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool)) + ) + , ( "course" + , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are + [] -> E.val True :: E.SqlExpr (E.Value Bool) + cshs -> E.exists . E.from $ \course -> do + E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId + E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs + ) + ] , dbtStyle = def , dbtIdent = "terms" :: Text } diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 8208d1a1f..0b6fb1c87 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} - module Handler.Users where import Import diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 2a5c6a160..da07f0477 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} - - module Handler.Utils ( module Handler.Utils ) where diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 67acd6a32..dcacedadb 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , OverloadedStrings - , RecordWildCards - , TypeFamilies - #-} - module Handler.Utils.DateTime ( utcToLocalTime , localTimeToUTC, TZ.LocalToUTCResult(..) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index c7b7aee21..fbfd9f8dc 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1,17 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} - module Handler.Utils.Form ( module Handler.Utils.Form , module Utils.Form diff --git a/src/Handler/Utils/Form/Types.hs b/src/Handler/Utils/Form/Types.hs index 386f029a0..16c8f0af6 100644 --- a/src/Handler/Utils/Form/Types.hs +++ b/src/Handler/Utils/Form/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} - module Handler.Utils.Form.Types where import Import diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 96ef448e0..4ade0952d 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , NamedFieldPuns - , TypeFamilies - , FlexibleContexts - , ViewPatterns - , LambdaCase - #-} - module Handler.Utils.Mail ( addRecipientsDB , userMailT diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 7702a7d52..b2b0d8a1e 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -1,16 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Handler.Utils.Rating ( Rating(..), Rating'(..) diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index d38d2e10a..e535eab8b 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - module Handler.Utils.Sheet where import Import diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index e4e8b38c7..75a82053b 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - #-} - module Handler.Utils.StudyFeatures ( parseStudyFeatures ) where diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 9f67bf0e0..78f836f46 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -1,19 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} - - module Handler.Utils.Submission ( AssignSubmissionException(..) , assignSubmissions diff --git a/src/Handler/Utils/Submission/TH.hs b/src/Handler/Utils/Submission/TH.hs index 99de8a01f..0b24a4da1 100644 --- a/src/Handler/Utils/Submission/TH.hs +++ b/src/Handler/Utils/Submission/TH.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , ViewPatterns - , OverloadedStrings - , StandaloneDeriving - , DeriveLift - #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Submission.TH diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 478bd58ff..d784d1cdc 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} - module Handler.Utils.Table where -- General Utilities for Tables diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 65bc11452..8b7da8308 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE FlexibleContexts #-} - module Handler.Utils.Table.Cells where import Import diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index ff2e81f64..f36fba523 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,23 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , ExistentialQuantification - , RecordWildCards - , NamedFieldPuns - , OverloadedStrings - , TemplateHaskell - , QuasiQuotes - , LambdaCase - , ViewPatterns - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , ScopedTypeVariables - , TupleSections - , RankNTypes - , MultiWayIf - , FunctionalDependencies - #-} - module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) , FilterColumn(..), IsFilterColumn @@ -47,7 +27,7 @@ module Handler.Utils.Table.Pagination import Handler.Utils.Table.Pagination.Types import Utils.Lens.TH -import Import hiding (Proxy(..)) +import Import import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Database.Esqueleto.Internal.Language as E (From) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 0a0b6c1c2..6bc9e1286 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , ExistentialQuantification - , RankNTypes - , RecordWildCards - #-} - module Handler.Utils.Table.Pagination.Types where import Import hiding (singleton) diff --git a/src/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs index 57ab0f1d6..bdd82db86 100644 --- a/src/Handler/Utils/Templates.hs +++ b/src/Handler/Utils/Templates.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, QuasiQuotes #-} - module Handler.Utils.Templates where import Data.Either (isLeft) diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index fb196c933..f1e5f5d7e 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 45c6c2d6a..51f05a9cb 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE CPP #-} module Import.NoFoundation ( module Import , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import diff --git a/src/Jobs.hs b/src/Jobs.hs index f89265009..112a1376f 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -1,29 +1,14 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , TemplateHaskell - , OverloadedStrings - , FlexibleContexts - , ViewPatterns - , TypeFamilies - , DeriveGeneric - , DeriveDataTypeable - , QuasiQuotes - , NamedFieldPuns - , MultiWayIf - #-} - module Jobs ( module Types , module Jobs.Queue , handleJobs ) where -import Import hiding (Proxy) +import Import import Jobs.Types as Types hiding (JobCtl(JobCtlQueue)) import Jobs.Types (JobCtl(JobCtlQueue)) import Jobs.Queue -import Jobs.TH import Jobs.Crontab import Data.Conduit.TMChan diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index ad0fecc21..abee018f4 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , FlexibleContexts - , MultiWayIf - , NamedFieldPuns - , TypeFamilies - #-} - module Jobs.Crontab ( determineCrontab ) where diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 0e03587a2..73642e90b 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , RecordWildCards - , OverloadedStrings - #-} - module Jobs.Handler.HelpRequest ( dispatchJobHelpRequest ) where diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 024d57682..444ffe935 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , NamedFieldPuns - #-} - module Jobs.Handler.QueueNotification ( dispatchJobQueueNotification ) where diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index a554bcfa8..529042a46 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -1,14 +1,9 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - #-} - module Jobs.Handler.SendNotification ( dispatchJobSendNotification ) where import Import -import Jobs.TH import Jobs.Types diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 6b7ed47d8..15f7a0289 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , NamedFieldPuns - , TemplateHaskell - , OverloadedStrings - #-} - module Jobs.Handler.SendNotification.CorrectionsAssigned ( dispatchNotificationCorrectionsAssigned ) where diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs index aaedcb7a6..0de2ff787 100644 --- a/src/Jobs/Handler/SendNotification/SheetActive.hs +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , NamedFieldPuns - , TemplateHaskell - , OverloadedStrings - #-} - module Jobs.Handler.SendNotification.SheetActive ( dispatchNotificationSheetActive ) where diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 6873d2b28..99248e777 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , NamedFieldPuns - , TemplateHaskell - , OverloadedStrings - #-} - module Jobs.Handler.SendNotification.SheetInactive ( dispatchNotificationSheetSoonInactive , dispatchNotificationSheetInactive @@ -55,4 +48,4 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do addAlternatives $ do let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet") providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) - \ No newline at end of file + diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 885dc8bfe..fd7543f47 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , NamedFieldPuns - , TemplateHaskell - , OverloadedStrings - #-} - module Jobs.Handler.SendNotification.SubmissionRated ( dispatchNotificationSubmissionRated ) where diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index 4b2865fdd..b66bbb471 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - , NamedFieldPuns - , QuasiQuotes - #-} - module Jobs.Handler.SendTestEmail ( dispatchJobSendTestEmail ) where diff --git a/src/Jobs/Handler/SetLogSettings.hs b/src/Jobs/Handler/SetLogSettings.hs index 01c8d618f..a7bf40f6c 100644 --- a/src/Jobs/Handler/SetLogSettings.hs +++ b/src/Jobs/Handler/SetLogSettings.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - #-} - module Jobs.Handler.SetLogSettings ( dispatchJobSetLogSettings ) where diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index d72734aeb..db5f2d8e5 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , TypeFamilies - #-} - module Jobs.Queue ( writeJobCtl, writeJobCtlBlock , queueJob, queueJob' diff --git a/src/Jobs/TH.hs b/src/Jobs/TH.hs deleted file mode 100644 index 47e69f62d..000000000 --- a/src/Jobs/TH.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , QuasiQuotes - , RecordWildCards - #-} - -module Jobs.TH - ( dispatchTH - ) where - -import ClassyPrelude - -import Language.Haskell.TH -import Language.Haskell.TH.Datatype - -import Data.List (foldl) - - -dispatchTH :: Name -- ^ Datatype to pattern match - -> ExpQ -dispatchTH dType = do - DatatypeInfo{..} <- reifyDatatype dType - let - matches = map mkMatch datatypeCons - mkMatch ConstructorInfo{..} = do - pats <- forM constructorFields $ \_ -> newName "x" - let fName = mkName $ "dispatch" <> nameBase constructorName - match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) [] - lamCaseE matches diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 63b947a69..20af81933 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE TemplateHaskell - , NoImplicitPrelude - , DeriveGeneric - , DeriveDataTypeable - #-} - module Jobs.Types ( Job(..), Notification(..) , JobCtl(..) diff --git a/src/Mail.hs b/src/Mail.hs index c812bc583..cbbc1c933 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -1,22 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude - , GeneralizedNewtypeDeriving - , DerivingStrategies - , FlexibleInstances - , MultiParamTypeClasses +{-# LANGUAGE GeneralizedNewtypeDeriving , UndecidableInstances - , DeriveGeneric - , TemplateHaskell - , OverloadedStrings - , RecordWildCards - , FlexibleContexts - , TypeFamilies - , ViewPatterns - , NamedFieldPuns - , MultiWayIf - , QuasiQuotes - , RankNTypes - , ScopedTypeVariables - , DeriveDataTypeable #-} module Mail diff --git a/src/Model.hs b/src/Model.hs index bd56ab5a2..15da993f1 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,17 +1,4 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} - module Model ( module Model @@ -44,12 +31,6 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course) - -data PWEntry = PWEntry - { pwUser :: User - , pwHash :: Text - } deriving (Show) -$(deriveJSON defaultOptions ''PWEntry) submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index bd6be6098..bdc362560 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} -{-# LANGUAGE TypeFamilies, FlexibleInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Model.Migration ( migrateAll ) where diff --git a/src/Model/Migration/Version.hs b/src/Model/Migration/Version.hs index 37bbd8f3f..2bc5579c9 100644 --- a/src/Model/Migration/Version.hs +++ b/src/Model/Migration/Version.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Migration.Version diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b4d3a41c5..0b10e1fb0 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -1,16 +1,6 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE MultiWayIf #-} -{-- # LANGUAGE ExistentialQuantification #-} -- for DA type +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) module Model.Types diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs index dc5a5eec6..4e2927edb 100644 --- a/src/Model/Types/JSON.hs +++ b/src/Model/Types/JSON.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} - module Model.Types.JSON ( derivePersistFieldJSON ) where diff --git a/src/Model/Types/Wordlist.hs b/src/Model/Types/Wordlist.hs index d4bab9e8c..5e35d7f25 100644 --- a/src/Model/Types/Wordlist.hs +++ b/src/Model/Types/Wordlist.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , ViewPatterns - , OverloadedStrings - #-} - module Model.Types.Wordlist (wordlist) where import ClassyPrelude hiding (lift) diff --git a/src/Settings.hs b/src/Settings.hs index da5fc9336..82b7f7ec0 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,17 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod @@ -22,7 +10,7 @@ module Settings , module Settings.Cluster ) where -import ClassyPrelude.Yesod hiding (Proxy) +import ClassyPrelude.Yesod import Data.UUID (UUID) import qualified Control.Exception as Exception import Data.Aeson (Result (..), fromJSON, withObject diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index 94bce92e0..25552d4a6 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , DataKinds - , TypeFamilies - , ScopedTypeVariables - , TemplateHaskell - , OverloadedStrings - , FlexibleContexts - #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Settings.Cluster diff --git a/src/Settings/StaticFiles.hs b/src/Settings/StaticFiles.hs index 0cefeaa1d..c8021d3a5 100644 --- a/src/Settings/StaticFiles.hs +++ b/src/Settings/StaticFiles.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Settings.StaticFiles where import Settings (appStaticDir, compileTimeAppSettings) diff --git a/src/Utils.hs b/src/Utils.hs index 17795138c..a95c79722 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} -{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult module Utils diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 69d230275..4e6c83a1c 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} -{-# LANGUAGE QuasiQuotes #-} - module Utils.DB where import ClassyPrelude.Yesod diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 2d58788e3..0b5855566 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -1,15 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , QuasiQuotes - , StandaloneDeriving - , DerivingStrategies - , DeriveLift - , DeriveDataTypeable - , DeriveGeneric - , GeneralizedNewtypeDeriving - , OverloadedStrings - , FlexibleInstances - #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Utils.DateTime diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6859eccea..e17678d06 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,18 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , TemplateHaskell - , ViewPatterns - , OverloadedStrings - , QuasiQuotes - , TemplateHaskell - , MultiParamTypeClasses - , TypeFamilies - , FlexibleContexts - , NamedFieldPuns - , ScopedTypeVariables - , MultiWayIf - , RecordWildCards -#-} - module Utils.Form where import ClassyPrelude.Yesod hiding (addMessage) diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs index 6556cede3..ab62d1baf 100644 --- a/src/Utils/Lang.hs +++ b/src/Utils/Lang.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - module Utils.Lang where import ClassyPrelude.Yesod diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 55f8d406c..d99d3c4a4 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} module Utils.Lens ( module Utils.Lens ) where import Import.NoFoundation diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index d0d61e68a..62e337328 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveLift #-} - - module Utils.Message ( MessageClass(..) , addMessage, addMessageI, addMessageIHamlet, addMessageFile diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 0aa1a364c..f093ce22f 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - #-} - module Utils.PathPiece ( finiteFromPathPiece , nullaryToPathPiece diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index ef2d2c6ea..f56ac38a2 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NumDecimals #-} -{-# LANGUAGE FlexibleContexts #-} - module Utils.Sql ( setSerializable ) where diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 80a7b7e00..e5cff0496 100644 --- a/src/Utils/SystemMessage.hs +++ b/src/Utils/SystemMessage.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude - , RecordWildCards - #-} - module Utils.SystemMessage where import Import.NoFoundation diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index c2d050bde..501cfee12 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Utils.TH where -- Common Utility Functions that require TemplateHaskell @@ -142,3 +136,16 @@ embedRenderMessageVariant f newT mangle = do ] ] + +dispatchTH :: Name -- ^ Datatype to pattern match + -> ExpQ +-- ^ Produces a lambda-case-expression matching all constructors of the named datatype and calling a function (named after the constructor prefixed with @dispatch@) on the fields of each constructor +dispatchTH dType = do + DatatypeInfo{..} <- reifyDatatype dType + let + matches = map mkMatch datatypeCons + mkMatch ConstructorInfo{..} = do + pats <- forM constructorFields $ \_ -> newName "x" + let fName = mkName $ "dispatch" <> nameBase constructorName + match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) [] + lamCaseE matches From 1b021259cc5d915d576576652d016fdeb6895ed5 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 09:44:40 +0100 Subject: [PATCH 02/13] SheetType refactoring (Halfway only) --- src/Foundation.hs | 4 ++-- src/Handler/Sheet.hs | 2 +- src/Model/Migration.hs | 6 ++++++ src/Model/Migration/Types.hs | 17 ++++++++++++++++ src/Model/Types.hs | 38 +++++++++++++++++++++++------------- src/Utils/Lens.hs | 4 ++++ 6 files changed, 54 insertions(+), 17 deletions(-) create mode 100644 src/Model/Migration/Types.hs diff --git a/src/Foundation.hs b/src/Foundation.hs index fe478f1ca..06e945166 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -882,7 +882,7 @@ defaultLinks = -- Define the menu items of the header. , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem - { menuItemLabel = "Einstellungen" + { menuItemLabel = "Anpassen" , menuItemIcon = Just "cogs" , menuItemRoute = ProfileR , menuItemModal = False @@ -917,7 +917,7 @@ defaultLinks = -- Define the menu items of the header. , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem - { menuItemLabel = "Korrekturen" + { menuItemLabel = "Korrektur" , menuItemIcon = Just "check" , menuItemRoute = CorrectionsR , menuItemModal = False diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e001b3a84..3eeba1975 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -65,7 +65,7 @@ import Control.Lens -- import Utils.Lens import qualified Data.Text as Text -import qualified Data.Aeson as Aeson +--import qualified Data.Aeson as Aeson import Control.Monad.Random.Class (MonadRandom(..)) import Utils.Sql diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index bd6be6098..03911070f 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -16,6 +16,7 @@ import Utils (lastMaybe) import Model import Model.Migration.Version +import qualified Model.Migration.Types as Legacy import Data.Map (Map) import qualified Data.Map as Map @@ -196,6 +197,11 @@ customMigrations = Map.fromListWith (>>) UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null; |] ) + , ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|] + , whenM (tableExists "sheet") $ do + sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |] + forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty] + ) ] diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs new file mode 100644 index 000000000..44c94b23d --- /dev/null +++ b/src/Model/Migration/Types.hs @@ -0,0 +1,17 @@ +module Model.Migration.Types where + +import qualified Model as Current + +data SheetType + = Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben + | Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben + | Pass { maxPoints, passingPoints :: Current.Points } + | NotGraded + deriving (Show, Read, Eq) + +sheetType :: SheetType -> Current.SheetType +sheetType = undefined + + +deriveJSON defaultOptions ''SheetType +derivePersistFieldJSON ''SheetType \ No newline at end of file diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b4d3a41c5..f57db4598 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -123,24 +123,34 @@ fromPoints = round instance DisplayAble Points -data SheetType - = Bonus { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben - | Normal { maxPoints :: Points } -- Erhöht das Maximum, wird gutgeschrieben --- | Informational { maxPoints :: Points } -- Erhöht nicht das Maximum Keine Gutschrift - | Pass { maxPoints, passingPoints :: Points } + +data SheetGrading + = Points { maxPoints :: Points } + | PassPoints { maxPoints, passingPoints :: Points } + | PassBinary + deriving (Eq, Read, Show) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = TaggedObject "type" "data" + } ''SheetGrading +derivePersistFieldJSON ''SheetGrading + +data SheetType + = Bonus { grading :: SheetGrading } + | Normal { grading :: SheetGrading } + | Informational { grading :: SheetGrading } | NotGraded - deriving (Show, Read, Eq) + deriving (Eq, Read, Show) -instance DisplayAble SheetType where - display (Bonus {..}) = tshow maxPoints <> " Bonuspunkte" - display (Normal{..}) = tshow maxPoints <> " Punkte" - display (Pass {..}) = "Bestanden ab " <> tshow (pToI passingPoints) <> " von " <> tshow maxPoints - display (NotGraded) = "Unbewertet" - -deriveJSON defaultOptions ''SheetType +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = TaggedObject "type" "data" + } ''SheetType derivePersistFieldJSON ''SheetType -makeLenses_ ''SheetType data SheetTypeSummary = SheetTypeSummary { sumBonusPoints :: Sum Points diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 55f8d406c..cf6507fc3 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -29,6 +29,10 @@ makeLenses_ ''SheetCorrector makeLenses_ ''SubmissionGroup +makeLenses_ ''SheetGrading + +makeLenses_ ''SheetType + -- makeClassy_ ''Load From 9d71dd7d9a1af3305c9852e327fc52c58ef45db8 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 12:26:47 +0100 Subject: [PATCH 03/13] Fixes #213 --- .vscode/tasks.json | 24 ++++- messages/uniworx/de.msg | 29 ++++-- src/Foundation.hs | 3 +- src/Handler/Corrections.hs | 5 +- src/Handler/Sheet.hs | 17 ++-- src/Handler/Utils/Form.hs | 92 ++++++++++--------- src/Handler/Utils/Rating.hs | 10 +- .../SendNotification/SubmissionRated.hs | 3 +- src/Jobs/Handler/SendTestEmail.hs | 2 +- src/Model/Migration/Types.hs | 22 ++++- src/Model/Types.hs | 13 ++- templates/correction-user.hamlet | 48 +++++----- templates/mail/submissionRated.hamlet | 47 +++++----- templates/widgets/rating.hamlet | 28 +++--- 14 files changed, 212 insertions(+), 131 deletions(-) diff --git a/.vscode/tasks.json b/.vscode/tasks.json index c5f9eaf8e..51fa5f4bf 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -4,12 +4,32 @@ "version": "2.0.0", "tasks": [ { - "label": "echo", + "label": "start", "type": "shell", - "command": "echo Hello", + "command": "./start.sh", + "group": "test", + "presentation": { + "echo": true, + "reveal": "always", + "focus": false, + "panel": "shared", + "showReuseMessage": true + } + }, + { + "label": "build", + "type": "shell", + "command": "stack build --flag uniworx:dev --flag uniworx:library-only", "group": { "kind": "build", "isDefault": true + }, + "presentation": { + "echo": true, + "reveal": "always", + "focus": false, + "panel": "shared", + "showReuseMessage": true } } ] diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f27bdb02b..4b7c8a3b0 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -351,18 +351,27 @@ MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage -SheetTypeBonus: Bonus -SheetTypeNormal: Normal -SheetTypePass: Bestehen -SheetTypeNotGraded: Keine Wertung +SheetGrading: Bewertung +SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte +SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten +SheetGradingPassBinary: Bestanden/Nicht Bestanden -SheetTypeBonus' maxPoints@Points: #{tshow maxPoints} Bonuspunkte -SheetTypeNormal' maxPoints@Points: #{tshow maxPoints} Punkte -SheetTypePass' maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten -SheetTypeNotGraded': Nicht gewertet +SheetGradingPoints': Punkte +SheetGradingPassPoints': Bestehen nach Punkten +SheetGradingPassBinary': Bestanden/Nicht bestanden -SheetTypeMaxPoints: Maximalpunktzahl -SheetTypePassingPoints: Notwendig zum Bestehen +SheetTypeBonus grading@SheetGrading: Bonus +SheetTypeNormal grading@SheetGrading: Normal +SheetTypeInformational grading@SheetGrading: Keine Wertung +SheetTypeNotGraded: Unbewertet + +SheetTypeBonus': Bonus +SheetTypeNormal': Normal +SheetTypeInformational': Keine Wertung +SheetTypeNotGraded': Unbewertet + +SheetGradingMaxPoints: Maximalpunktzahl +SheetGradingPassingPoints: Notwendig zum Bestehen SheetGroupArbitrary: Arbiträre Gruppen SheetGroupRegisteredGroups: Registrierte Gruppen diff --git a/src/Foundation.hs b/src/Foundation.hs index 3f30e95b8..cd09b4ad8 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -222,10 +222,11 @@ instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where embedRenderMessage ''UniWorX ''MessageClass ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel -embedRenderMessage ''UniWorX ''SheetType $ \st -> "SheetType" <> st <> "'" embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType id embedRenderMessage ''UniWorX ''CorrectorState id +embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) +embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>) newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index c1961857e..9e2285d40 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -535,6 +535,8 @@ postCorrectionR tid ssh csh shn cid = do addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + mr <- getMessageRender + let sheetTypeDesc = mr sheetType defaultLayout $ do let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") @@ -546,8 +548,9 @@ getCorrectionUserR tid ssh csh shn cid = do case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do + mr <- getMessageRender let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) - + sheetTypeDesc = mr sheetType defaultLayout $ do $(widgetFile "correction-user") _ -> notFound diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index a9fe048b1..0a25a30a6 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -44,8 +44,8 @@ import qualified Data.Map as Map import Data.Monoid (Sum(..), Any(..)) -import Control.Lens --- import Utils.Lens +-- import Control.Lens +import Utils.Lens import qualified Data.Text as Text --import qualified Data.Aeson as Aeson @@ -166,7 +166,7 @@ getSheetListR tid ssh csh = do , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo , sortable Nothing (i18nCell MsgSheetType) - $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType + $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType , sortable Nothing (i18nCell MsgSubmission) $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of Nothing -> mempty @@ -190,12 +190,11 @@ getSheetListR tid ssh csh = do (i18nCell MsgRatingPercent) $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> - case sType of - NotGraded -> mempty - _ | maxPoints sType > 0 -> - let percent = sPoints / maxPoints sType - in textCell $ textPercent $ realToFrac percent - _other -> mempty + case preview (_grading . _maxPoints) sType of + (Nothing) -> mempty + (Just maxPoints) -> + let percent = sPoints / maxPoints + in textCell $ textPercent $ realToFrac percent _other -> mempty ] psValidator = def diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index fbfd9f8dc..f3feaa06f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -313,7 +313,23 @@ multiFileField permittedFiles' = Field{..} Right _ -> return () Left r -> yield r -data SheetType' = Bonus' | Normal' | Pass' | NotGraded' + +data SheetGrading' = Points' | PassPoints' | PassBinary' + deriving (Eq, Ord, Read, Show, Enum, Bounded) + +instance Universe SheetGrading' +instance Finite SheetGrading' + +$(return []) + +instance PathPiece SheetGrading' where + toPathPiece = $(nullaryToPathPiece ''SheetGrading' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"]) + fromPathPiece = finiteFromPathPiece + +embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) + + +data SheetType' = Bonus' | Normal' | Informational' | NotGraded' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetType' @@ -325,14 +341,8 @@ instance PathPiece SheetType' where toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"]) fromPathPiece = finiteFromPathPiece -instance RenderMessage UniWorX SheetType' where - renderMessage f ls = \case - Bonus' -> render MsgSheetTypeBonus - Normal' -> render MsgSheetTypeNormal - Pass' -> render MsgSheetTypePass - NotGraded' -> render MsgSheetTypeNotGraded - where - render = renderMessage f ls +embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>) + data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups' deriving (Eq, Ord, Read, Show, Enum, Bounded) @@ -354,44 +364,40 @@ instance RenderMessage UniWorX SheetGroup' where where render = renderMessage f ls -sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType -sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do - let - selOptions = Map.fromList - [ ( Bonus', Bonus <$> maxPointsReq ) - , ( Normal', Normal <$> maxPointsReq ) - , ( Pass', Pass - <$> maxPointsReq - <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template) - ) - , ( NotGraded', pure NotGraded ) +sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading +sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template) + where + selOptions = Map.fromList + [ ( Points', Points <$> maxPointsReq ) + , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq ) + , ( PassBinary', pure PassBinary) ] - (res, selView) <- multiAction selOptions (classify' <$> template) - - fvId <- maybe newIdent return fsId - MsgRenderer mr <- getMsgRenderer - - return (res, - [ FieldView - { fvLabel = toHtml $ mr fsLabel - , fvTooltip = toHtml . mr <$> fsTooltip - , fvId - , fvInput = selView - , fvErrors = case res of - FormFailure [e] -> Just $ toHtml e - _ -> Nothing - , fvRequired = True - } - ]) - - where - maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template) + classify' :: SheetGrading -> SheetGrading' + classify' = \case + Points {} -> Points' + PassPoints {} -> PassPoints' + PassBinary {} -> PassBinary' + 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 + selOptions = Map.fromList + [ ( Bonus' , Bonus <$> gradingReq ) + , ( Normal', Normal <$> gradingReq ) + , ( Informational', Informational <$> gradingReq ) + , ( NotGraded', pure NotGraded ) + ] + gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading) (template >>= preview _grading) + classify' :: SheetType -> SheetType' classify' = \case - Bonus _ -> Bonus' - Normal _ -> Normal' - Pass _ _ -> Pass' + Bonus {} -> Bonus' + Normal {} -> Normal' + Informational {} -> Informational' NotGraded -> NotGraded' sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index b2b0d8a1e..b5438b299 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -45,6 +45,8 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit +import Utils.Lens hiding ((<.>)) + instance HasResolution prec => Pretty (Fixed prec) where pretty = pretty . show @@ -53,6 +55,12 @@ instance Pretty x => Pretty (CI x) where pretty = pretty . CI.original +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 ) + + data Rating = Rating { ratingCourseName :: CourseName , ratingSheetName :: SheetName @@ -119,7 +127,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let [ Just $ "Veranstaltung:" <+> pretty ratingCourseName , Just $ "Blatt:" <+> pretty ratingSheetName , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName - , Just $ "Bewertung:" <+> pretty (display ratingSheetType) + , ("Bewertung:" <+>) . pretty <$> (ratingSheetType ^? _grading) ] , "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID) , "=============================================" diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index fd7543f47..204ac5392 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -25,6 +25,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien csid <- encrypt nSubmission MsgRenderer mr <- getMailMsgRenderer let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + let sheetTypeDesc = mr sheetType submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime let tid = courseTerm ssh = courseSchool @@ -39,7 +40,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien , "submission-rating-comment" Aeson..= submissionRatingComment , "submission-rating-time" Aeson..= submissionRatingTime , "submission-rating-by" Aeson..= (userDisplayName <$> corrector) - , "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType) + , "submission-rating-passed" Aeson..= (join $ gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints) , "sheet-name" Aeson..= sheetName , "sheet-type" Aeson..= sheetType , "course-name" Aeson..= courseName diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index b66bbb471..5c5cd0900 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -2,7 +2,7 @@ module Jobs.Handler.SendTestEmail ( dispatchJobSendTestEmail ) where -import Import hiding ((.=)) +import Import import Handler.Utils.DateTime diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 44c94b23d..c3885f3ff 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -1,6 +1,15 @@ module Model.Migration.Types where - + +import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value()) +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) +import Database.Persist.Sql + import qualified Model as Current +import qualified Model.Types.JSON as Current data SheetType = Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben @@ -10,8 +19,15 @@ data SheetType deriving (Show, Read, Eq) sheetType :: SheetType -> Current.SheetType -sheetType = undefined +sheetType Bonus {..} = Current.Bonus $ Current.Points {..} +sheetType Normal {..} = Current.Normal $ Current.Points {..} +sheetType Pass {..} = Current.Normal $ Current.PassPoints {..} +sheetType NotGraded = Current.NotGraded + +{- TODO: + * RenderMessage instance for newtype(SheetType) if needed +-} deriveJSON defaultOptions ''SheetType -derivePersistFieldJSON ''SheetType \ No newline at end of file +Current.derivePersistFieldJSON ''SheetType \ No newline at end of file diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 6e3320c52..acd08a9a6 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -117,7 +117,7 @@ instance DisplayAble Points data SheetGrading = Points { maxPoints :: Points } | PassPoints { maxPoints, passingPoints :: Points } - | PassBinary + | PassBinary -- non-zero means passed deriving (Eq, Read, Show) deriveJSON defaultOptions @@ -127,6 +127,12 @@ deriveJSON defaultOptions } ''SheetGrading derivePersistFieldJSON ''SheetGrading +gradingPassed :: SheetGrading -> Points -> Maybe Bool +gradingPassed (Points {}) _ = Nothing +gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints +gradingPassed (PassBinary {}) pts = Just $ pts /= 0 + + data SheetType = Bonus { grading :: SheetGrading } | Normal { grading :: SheetGrading } @@ -156,12 +162,15 @@ instance Monoid SheetTypeSummary where mempty = memptydefault mappend = mappenddefault + sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary +sheetTypeSum = error "TODO sheetTypeSum" +{- sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved } sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved } sheetTypeSum (Pass{..}, achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved} sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } - +-} data SheetGroup = Arbitrary { maxParticipants :: Natural } diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index a3036193f..8c0b21a71 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -11,28 +11,34 @@ _{MsgRatingTime} ^{formatTimeW SelFormatDateTime time} + $maybe points <- submissionRatingPoints - $case sheetType - $of Bonus{..} - - _{MsgAchievedBonusPoints} - _{MsgAchievedOf points maxPoints} - $of Normal{..} - - _{MsgAchievedNormalPoints} - _{MsgAchievedOf points maxPoints} - $of Pass{..} - - _{MsgPassedResult} - - $if points >= passingPoints - _{MsgPassed} - $else - _{MsgNotPassed} - - _{MsgAchievedPassPoints} - _{MsgPassAchievedOf points passingPoints maxPoints} - $of NotGraded + $maybe grading <- preview _grading sheetType + $case grading + $of Points{..} + + #{sheetTypeDesc} + _{MsgAchievedOf points maxPoints} + $of PassPoints{..} + + #{sheetTypeDesc} + + $if fromMaybe False (gradingPassed grading points) + _{MsgPassed} + $else + _{MsgNotPassed} + + _{MsgAchievedPassPoints} + _{MsgPassAchievedOf points passingPoints maxPoints} + $of PassBinary + + #{sheetTypeDesc} + + $if fromMaybe False (gradingPassed grading points) + _{MsgPassed} + $else + _{MsgNotPassed} + $maybe comment <- ratingComment _{MsgRatingComment} diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet index d808e4927..77b7ba80c 100644 --- a/templates/mail/submissionRated.hamlet +++ b/templates/mail/submissionRated.hamlet @@ -33,31 +33,30 @@ $newline never _{MsgRatingTime}
#{time} +
#{sheetTypeDesc} $maybe points <- submissionRatingPoints - $case sheetType - $of Bonus{..} -
- _{MsgAchievedBonusPoints} -
- _{MsgAchievedOf points maxPoints} - $of Normal{..} -
- _{MsgAchievedNormalPoints} -
- _{MsgAchievedOf points maxPoints} - $of Pass{..} -
- _{MsgPassedResult} -
- $if points >= passingPoints - _{MsgPassed} - $else - _{MsgNotPassed} -
- _{MsgAchievedPassPoints} -
- _{MsgPassAchievedOf points passingPoints maxPoints} - $of NotGraded + $maybe grading <- preview _grading sheetType + $case grading + $of Points{..} +
+ _{MsgAchievedOf points maxPoints} + $of PassPoints{..} +
+ $if fromMaybe False (gradingPassed grading points) + _{MsgPassed} + $else + _{MsgNotPassed} +
+ _{MsgAchievedPassPoints} +
+ _{MsgPassAchievedOf points passingPoints maxPoints} + $of PassBinary +
+ $if fromMaybe False (gradingPassed grading points) + _{MsgPassed} + $else + _{MsgNotPassed} + $maybe comment <- submissionRatingComment
_{MsgRatingComment} diff --git a/templates/widgets/rating.hamlet b/templates/widgets/rating.hamlet index 177119151..2b3d021e1 100644 --- a/templates/widgets/rating.hamlet +++ b/templates/widgets/rating.hamlet @@ -2,15 +2,19 @@ $# Display Rating, expects $# submissionRatingPoints :: Maybe points $maybe points <- submissionRatingPoints - $case sheetType - $of Bonus{..} - _{MsgAchievedOf points maxPoints} - $of Normal{..} - _{MsgAchievedOf points maxPoints} - $of Pass{..} - $if points >= passingPoints - _{MsgPassed} - $else - _{MsgNotPassed} - $of NotGraded - #{display tickmarkS} + $maybe grading <- preview _grading sheetType + $case grading + $of Points{..} + _{MsgAchievedOf points maxPoints} + $of PassPoints{..} + $if fromMaybe False (gradingPassed grading points) + _{MsgPassed} + $else + _{MsgNotPassed} + $of PassBinary + $if fromMaybe False (gradingPassed grading points) + _{MsgPassed} + $else + _{MsgNotPassed} + $nothing + #{tickmarkS} From 3adac1f25b7a647af4495c25e593a0901be66e7a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 31 Oct 2018 13:20:35 +0100 Subject: [PATCH 04/13] Fixes #85 --- src/Handler/Utils/Form.hs | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index c7b7aee21..7e11e014b 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -282,26 +282,23 @@ multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either multiFileField permittedFiles' = Field{..} where fieldEnctype = Multipart - fieldParse vals files - | null files - , null vals = return $ Right Nothing - | otherwise = return . Right . Just $ do - pVals <- lift permittedFiles' - let - decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId) - decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt - yieldMany vals - .| C.filter (/= unpackZips) - .| C.map fromPathPiece .| C.catMaybes - .| C.mapMaybeM decrypt' - .| C.filter (`elem` pVals) - .| C.map Left - let - handleFile :: FileInfo -> Source Handler File - handleFile - | doUnpack = sourceFiles - | otherwise = yieldM . acceptFile - mapM_ handleFile files .| C.map Right + fieldParse vals files = return . Right . Just $ do + pVals <- lift permittedFiles' + let + decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId) + decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt + yieldMany vals + .| C.filter (/= unpackZips) + .| C.map fromPathPiece .| C.catMaybes + .| C.mapMaybeM decrypt' + .| C.filter (`elem` pVals) + .| C.map Left + let + handleFile :: FileInfo -> Source Handler File + handleFile + | doUnpack = sourceFiles + | otherwise = yieldM . acceptFile + mapM_ handleFile files .| C.map Right where doUnpack = unpackZips `elem` vals fieldView fieldId fieldName attrs val req = do From e5a0cecd7e557d963621ea34e49dd0257b0e6efb Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 13:43:25 +0100 Subject: [PATCH 05/13] .vscode added to ignored files --- .gitignore | 1 + .vscode/tasks.json | 36 ------------------------------------ 2 files changed, 1 insertion(+), 36 deletions(-) delete mode 100644 .vscode/tasks.json diff --git a/.gitignore b/.gitignore index 84a8fe8a9..663c0dcc1 100644 --- a/.gitignore +++ b/.gitignore @@ -31,3 +31,4 @@ src/Handler/Course.SnapCustom.hs .stack-work-* .directory tags +.vscode \ No newline at end of file diff --git a/.vscode/tasks.json b/.vscode/tasks.json deleted file mode 100644 index 51fa5f4bf..000000000 --- a/.vscode/tasks.json +++ /dev/null @@ -1,36 +0,0 @@ -{ - // See https://go.microsoft.com/fwlink/?LinkId=733558 - // for the documentation about the tasks.json format - "version": "2.0.0", - "tasks": [ - { - "label": "start", - "type": "shell", - "command": "./start.sh", - "group": "test", - "presentation": { - "echo": true, - "reveal": "always", - "focus": false, - "panel": "shared", - "showReuseMessage": true - } - }, - { - "label": "build", - "type": "shell", - "command": "stack build --flag uniworx:dev --flag uniworx:library-only", - "group": { - "kind": "build", - "isDefault": true - }, - "presentation": { - "echo": true, - "reveal": "always", - "focus": false, - "panel": "shared", - "showReuseMessage": true - } - } - ] -} \ No newline at end of file From 4ea061ea177c59493e1102338215185f7e12d51e Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 14:39:15 +0100 Subject: [PATCH 06/13] Fix build. --- db.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/db.hs b/db.hs index e2d130fe7..d28038000 100755 --- a/db.hs +++ b/db.hs @@ -299,7 +299,7 @@ fillDb = do { sheetCourse = pmo , sheetName = "Blatt 1" , sheetDescription = Nothing - , sheetType = Normal 6 + , sheetType = Normal $ Points 6 , sheetGrouping = Arbitrary 3 , sheetMarkingText = Nothing , sheetVisibleFrom = Just now From 49de7c7113efbc8b828879a58ab477fef02b0ee8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 31 Oct 2018 15:10:06 +0100 Subject: [PATCH 07/13] Fix build --- build.sh | 3 +++ db.hs | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) create mode 100755 build.sh diff --git a/build.sh b/build.sh new file mode 100755 index 000000000..991d2ff3c --- /dev/null +++ b/build.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev diff --git a/db.hs b/db.hs index e2d130fe7..d28038000 100755 --- a/db.hs +++ b/db.hs @@ -299,7 +299,7 @@ fillDb = do { sheetCourse = pmo , sheetName = "Blatt 1" , sheetDescription = Nothing - , sheetType = Normal 6 + , sheetType = Normal $ Points 6 , sheetGrouping = Arbitrary 3 , sheetMarkingText = Nothing , sheetVisibleFrom = Just now From 73bd8bf9f0cbdeb86ecf0275f7560b8832f36aaa Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 15:48:34 +0100 Subject: [PATCH 08/13] Fixes #222 --- messages/uniworx/de.msg | 1 + src/Foundation.hs | 9 +++++++++ src/Handler/Corrections.hs | 4 +++- src/Handler/Utils/Form.hs | 3 +++ templates/sheetShow.hamlet | 2 +- 5 files changed, 17 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4b7c8a3b0..7c03d6713 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -258,6 +258,7 @@ RatingDone: Bewertung fertiggestellt RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein +PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist ColumnRatingPointsDone: Punktzahl/Abgeschlossen Pseudonyms: Pseudonyme diff --git a/src/Foundation.hs b/src/Foundation.hs index cd09b4ad8..dc350557d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -228,6 +228,15 @@ embedRenderMessage ''UniWorX ''CorrectorState id embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>) +newtype SheetTypeComplete = SheetTypeComplete SheetType +instance RenderMessage UniWorX (SheetTypeComplete) where + renderMessage foundation ls (SheetTypeComplete st) = case st of + NotGraded -> mr NotGraded + other -> mr (grading other) <> ", " <> mr other + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 9e2285d40..7e4247d19 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -486,7 +486,9 @@ postCorrectionR tid ssh csh shn cid = do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) pointsForm = case sheetType of NotGraded -> pure Nothing - _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints) + _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) + (fslpI MsgRatingPoints "Punktezahl") + (Just $ submissionRatingPoints) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cc3d146fc..9fc3a8daf 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -193,6 +193,9 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific) return . fromRational $ round (sci * 100) % 100 +pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions +pointsFieldMax Nothing = pointsField +pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField termsActiveField :: Field Handler TermId termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 9efdc5e24..7776c0bc8 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
_{MsgSheetSolutionFrom}
#{solution}
_{MsgSheetType} -
_{sheetType sheet} +
_{SheetTypeComplete (sheetType sheet)} $if CorrectorSubmissions == sheetSubmissionMode sheet
_{MsgSheetPseudonym}
From d6ef0c1b651e89964c3839fbd5c1a590b30a9ca0 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 17:07:19 +0100 Subject: [PATCH 09/13] Tooltips clarifying sheetTypes and sheetGrading at sheet creation --- messages/uniworx/de.msg | 2 ++ src/Handler/Sheet.hs | 3 ++- src/Handler/Utils/Form.hs | 3 ++- src/Model/Types.hs | 23 ++++++++++++++++++----- 4 files changed, 24 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7c03d6713..548904e49 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -356,6 +356,7 @@ SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten SheetGradingPassBinary: Bestanden/Nicht Bestanden +SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. SheetGradingPoints': Punkte SheetGradingPassPoints': Bestehen nach Punkten @@ -365,6 +366,7 @@ 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 nicht angerechnet, eine Punktangabe dient dort nur zur Rückmeldung an die Teilnehmer. SheetTypeBonus': Bonus SheetTypeNormal': Normal diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 0a25a30a6..9870665f2 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -102,7 +102,8 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq ciField (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) - <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template) + <*> sheetTypeAFormReq (fslI MsgSheetType + & setTooltip MsgSheetTypeInfo) (sfType <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9fc3a8daf..c30458e16 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -391,7 +391,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa , ( Informational', Informational <$> gradingReq ) , ( NotGraded', pure NotGraded ) ] - gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading) (template >>= preview _grading) + gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading + & setTooltip MsgSheetGradingInfo) (template >>= preview _grading) classify' :: SheetType -> SheetType' classify' = \case diff --git a/src/Model/Types.hs b/src/Model/Types.hs index acd08a9a6..5dabaed5b 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -132,6 +132,16 @@ gradingPassed (Points {}) _ = Nothing gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints gradingPassed (PassBinary {}) pts = Just $ pts /= 0 +-- just for SheetTypeSummary (no lenses available here?!) +getMaxPoints :: SheetGrading -> Points +getMaxPoints PassBinary = 0 +getMaxPoints other = maxPoints other + +getPassPoints :: SheetGrading -> Points +getPassPoints PassPoints {..} = passingPoints +getPassPoints _ = 0 + + data SheetType = Bonus { grading :: SheetGrading } @@ -152,6 +162,7 @@ data SheetTypeSummary = SheetTypeSummary { sumBonusPoints :: Sum Points , sumNormalPoints :: Sum Points , numPassSheets :: Sum Int + , numPassBonus :: Sum Int , numNotGraded :: Sum Int , achievedBonus :: Maybe (Sum Points) , achievedNormal :: Maybe (Sum Points) @@ -164,12 +175,14 @@ instance Monoid SheetTypeSummary where sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary -sheetTypeSum = error "TODO sheetTypeSum" +-- sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum $ fromMaybe 0 (grading ^? _maxPoints), achievedBonus = Sum <$> achieved } +sheetTypeSum = error "TODO" {- -sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved } -sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved } -sheetTypeSum (Pass{..}, achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved} -sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } +sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum $ getMaxPoints grading + , achievedBonus = Sum <$> achieved } +sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum $ getMaxPoints grading, achievedNormal = Sum <$> achieved } +sheetTypeSum (Informational{..}, achieved) = mempty { } +sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } -} data SheetGroup From af77f1cab3c14cf683fd892365825797d13880d7 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 1 Nov 2018 16:04:46 +0100 Subject: [PATCH 10/13] Fixes #222. Fixes #213. Bug with Summary-Display (not summing up properly). --- messages/uniworx/de.msg | 2 +- src/Handler/Sheet.hs | 6 +-- src/Handler/Utils/Table/Cells.hs | 3 ++ src/Model/Types.hs | 61 ++++++++++++----------- src/Utils.hs | 8 +++ templates/widgets/sheetTypeSummary.hamlet | 56 ++++++++++++--------- 6 files changed, 79 insertions(+), 57 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 548904e49..b131bc5ab 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -366,7 +366,7 @@ 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 nicht angerechnet, eine Punktangabe dient dort nur zur Rückmeldung an die Teilnehmer. +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. SheetTypeBonus': Bonus SheetTypeNormal': Normal diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9870665f2..c0dc152d1 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -167,7 +167,7 @@ getSheetListR tid ssh csh = do , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo , sortable Nothing (i18nCell MsgSheetType) - $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType + $ \(Entity _ Sheet{..}, _, _) -> i18nCell $ SheetTypeComplete sheetType , sortable Nothing (i18nCell MsgSubmission) $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of Nothing -> mempty @@ -186,8 +186,8 @@ getSheetListR tid ssh csh = do cid <- mkCid return $ CSubmissionR tid ssh csh sheetName cid CorrectionR protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") - in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) - , sortable Nothing -- (Just "percent") + in protoCell & cellContents %~ (<* tell (sheetTypeSum sheetType submissionRatingPoints)) + , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 8b7da8308..728c91a83 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -83,6 +83,9 @@ sheetCell crse shn = link= CSheetR tid ssh csh shn SShowR in anchorCell link $ display2widget shn +sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a +sheetTypeCell st = i18nCell $ SheetTypeComplete st + submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a submissionCell crse shn sid = let tid = crse ^. _1 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 5dabaed5b..396c26bbb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -132,20 +132,34 @@ gradingPassed (Points {}) _ = Nothing gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints gradingPassed (PassBinary {}) pts = Just $ pts /= 0 --- just for SheetTypeSummary (no lenses available here?!) -getMaxPoints :: SheetGrading -> Points -getMaxPoints PassBinary = 0 -getMaxPoints other = maxPoints other +data SheetGradeSummary = SheetGradeSummary + { sumGradePoints :: Sum Points + , numGradePasses :: Sum Int + , achievedPoints :: Maybe (Sum Points) + , achievedPasses :: Maybe (Sum Int) +} deriving (Generic) -getPassPoints :: SheetGrading -> Points -getPassPoints PassPoints {..} = passingPoints -getPassPoints _ = 0 +instance Monoid SheetGradeSummary where + mempty = memptydefault + mappend = mappenddefault +instance Semigroup SheetGradeSummary where + (<>) = mappend -- remove for GHC > 8.4.x +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 } + data SheetType - = Bonus { grading :: SheetGrading } - | Normal { grading :: SheetGrading } + = Normal { grading :: SheetGrading } + | Bonus { grading :: SheetGrading } | Informational { grading :: SheetGrading } | NotGraded deriving (Eq, Read, Show) @@ -157,33 +171,20 @@ deriveJSON defaultOptions } ''SheetType derivePersistFieldJSON ''SheetType - data SheetTypeSummary = SheetTypeSummary - { sumBonusPoints :: Sum Points - , sumNormalPoints :: Sum Points - , numPassSheets :: Sum Int - , numPassBonus :: Sum Int - , numNotGraded :: Sum Int - , achievedBonus :: Maybe (Sum Points) - , achievedNormal :: Maybe (Sum Points) - , achievedPasses :: Maybe (Sum Int) + { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary + , numNotGraded :: Sum Int } deriving (Generic) instance Monoid SheetTypeSummary where - mempty = memptydefault + mempty = memptydefault mappend = mappenddefault - -sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary --- sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum $ fromMaybe 0 (grading ^? _maxPoints), achievedBonus = Sum <$> achieved } -sheetTypeSum = error "TODO" -{- -sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum $ getMaxPoints grading - , achievedBonus = Sum <$> achieved } -sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum $ getMaxPoints grading, achievedNormal = Sum <$> achieved } -sheetTypeSum (Informational{..}, achieved) = mempty { } -sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } --} +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 } data SheetGroup = Arbitrary { maxParticipants :: Natural } diff --git a/src/Utils.hs b/src/Utils.hs index a95c79722..2c10470a6 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -8,6 +8,7 @@ import ClassyPrelude.Yesod -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import Data.Foldable as Fold hiding (length) +import Data.Monoid (Sum(..)) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -302,6 +303,13 @@ ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argu ifMaybeM Nothing dft _ = return dft ifMaybeM (Just x) _ act = act x +maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if +maybePositive a | a > 0 = Just a + | otherwise = Nothing + +positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive +positiveSum (Sum x) = maybePositive x + maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act diff --git a/templates/widgets/sheetTypeSummary.hamlet b/templates/widgets/sheetTypeSummary.hamlet index 581dc0791..f74f5dccf 100644 --- a/templates/widgets/sheetTypeSummary.hamlet +++ b/templates/widgets/sheetTypeSummary.hamlet @@ -1,23 +1,33 @@ -
- $if 0 < getSum sumNormalPoints - Gesamtpunktzahl #{display (getSum sumNormalPoints)} - $maybe nPts <- (maybeAdd (getSum <$> achievedNormal) (getSum <$> achievedBonus)) - \ davon #{display nPts} erreicht - $maybe bPts <- getSum <$> achievedBonus - \ (inklusive #{display bPts} # - $if 0 < getSum sumBonusPoints - von #{display $ getSum sumBonusPoints} erreichbaren # - Bonuspunkten) - \ #{textPercent $ realToFrac $ nPts / (getSum sumNormalPoints)} - - -
- $if 0 < getSum numPassSheets - Blätter zum Bestehen: #{display (getSum numPassSheets)} - $maybe passed <- getSum <$> achievedPasses - \ davon #{display passed} bestanden. - -
- $if 0 < getSum numNotGraded - Unbewertet: #{display (getSum numNotGraded)} Blätter - +$with realGrades <- normalSummary <> bonusSummary + $with allGrades <- realGrades <> informationalSummary +
+ $maybe realPoints <- positiveSum (sumGradePoints realGrades) + Gesamtpunktzahl #{display realPoints} + $maybe nPts <- getSum <$> achievedPoints realGrades + \ davon #{display nPts} erreicht + $maybe bPts <- getSum <$> achievedPoints bonusSummary + \ (inklusive #{display bPts} # + $maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary) + von #{display achievedBonus} erreichbaren # + Bonuspunkten) + \ #{textPercent $ realToFrac $ nPts / realPoints} + $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary) + 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 + \ #{textPercent $ realToFrac $ achievedFakes / fakePoints} + . +
+ $maybe reqPasses <- positiveSum (numGradePasses normalSummary) + Aufgaben zum Bestehen: #{display reqPasses} + $maybe passed <- getSum <$> achievedPasses realGrades + \ davon #{display passed} bestanden + $maybe bonusPassed <- getSum <$> achievedPasses bonusSummary + \ (inklusive #{display bonusPassed} Bonusaufgaben) + . +
+ $maybe noGradeSheets <- positiveSum numNotGraded + #{display noGradeSheets} unbewertete Aufgabenblätter. + From e4e5b543a57176b2f7178c04e2619f318dfc8cf2 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 1 Nov 2018 17:01:40 +0100 Subject: [PATCH 11/13] Workaround for unfixed issue #223 --- src/Handler/Sheet.hs | 18 ++++++- templates/widgets/sheetTypeSummary.hamlet | 65 ++++++++++++----------- 2 files changed, 52 insertions(+), 31 deletions(-) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c0dc152d1..dec893ce7 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -200,7 +200,23 @@ getSheetListR tid ssh csh = do ] psValidator = def & defaultSorting [("submission-since", SortAsc)] - (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable + ------------------------------------------------------ + -- ISSUE #223 + -- The following line does not work; something is wrong with the tell in line 189 above. + -- (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable + -- + -- If fixed, remove the following workaround code: + SheetTypeSummary{..} <- 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 + E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) + return $ foldMap (\(E.Value st, E.Value mbPts) -> sheetTypeSum st (join mbPts)) rows + (_, table) <- dbTable psValidator $ DBTable + -- END ISSUE #223 + ----------------------------------------------------- { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } diff --git a/templates/widgets/sheetTypeSummary.hamlet b/templates/widgets/sheetTypeSummary.hamlet index f74f5dccf..4a86f9a34 100644 --- a/templates/widgets/sheetTypeSummary.hamlet +++ b/templates/widgets/sheetTypeSummary.hamlet @@ -1,33 +1,38 @@ $with realGrades <- normalSummary <> bonusSummary $with allGrades <- realGrades <> informationalSummary
- $maybe realPoints <- positiveSum (sumGradePoints realGrades) - Gesamtpunktzahl #{display realPoints} - $maybe nPts <- getSum <$> achievedPoints realGrades - \ davon #{display nPts} erreicht - $maybe bPts <- getSum <$> achievedPoints bonusSummary - \ (inklusive #{display bPts} # - $maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary) - von #{display achievedBonus} erreichbaren # - Bonuspunkten) - \ #{textPercent $ realToFrac $ nPts / realPoints} - $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary) - 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 - \ #{textPercent $ realToFrac $ achievedFakes / fakePoints} - . -
- $maybe reqPasses <- positiveSum (numGradePasses normalSummary) - Aufgaben zum Bestehen: #{display reqPasses} - $maybe passed <- getSum <$> achievedPasses realGrades - \ davon #{display passed} bestanden - $maybe bonusPassed <- getSum <$> achievedPasses bonusSummary - \ (inklusive #{display bonusPassed} Bonusaufgaben) - . -
- $maybe noGradeSheets <- positiveSum numNotGraded - #{display noGradeSheets} unbewertete Aufgabenblätter. - +
    + $maybe realPoints <- positiveSum (sumGradePoints realGrades) +
  • + Gesamtpunktzahl #{display realPoints} + $maybe nPts <- getSum <$> achievedPoints realGrades + \ davon #{display nPts} erreicht + $maybe bPts <- getSum <$> achievedPoints bonusSummary + \ (inklusive #{display bPts} # + $maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary) + von #{display achievedBonus} erreichbaren # + Bonuspunkten) + \ #{textPercent $ realToFrac $ nPts / realPoints} + $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary) +
  • + 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 + \ #{textPercent $ realToFrac $ achievedFakes / fakePoints} + . + + $maybe reqPasses <- positiveSum (numGradePasses normalSummary) +
  • + Aufgaben zum Bestehen: #{display reqPasses} + $maybe passed <- getSum <$> achievedPasses realGrades + \ davon #{display passed} bestanden + $maybe bonusPassed <- getSum <$> achievedPasses bonusSummary + \ (inklusive #{display bonusPassed} Bonusaufgaben) + . + + $maybe noGradeSheets <- positiveSum numNotGraded +
  • + #{display noGradeSheets} unbewertete Aufgabenblätter. + From 9aaee52ce12f3d80fdc36c4496fe3a1939e6feba Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 2 Nov 2018 12:20:43 +0100 Subject: [PATCH 12/13] BUGFIX: sort corrections by assigned time (undefined sortColumn) --- src/Handler/Corrections.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 7e4247d19..743bee3c1 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -238,6 +238,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do , ( "ratingtime" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime ) + , ( "assignedtime" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned + ) ] , dbtFilter = Map.fromList [ ( "term" From a29b0eac03ce5fb75147fbaf5ff6be5bae1e2a25 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 2 Nov 2018 14:11:13 +0100 Subject: [PATCH 13/13] Add some missing form actions --- templates/correction.hamlet | 4 ++-- templates/corrections-upload.hamlet | 2 +- templates/corrections.hamlet | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/templates/correction.hamlet b/templates/correction.hamlet index 9c5c0ed39..d2f7934d2 100644 --- a/templates/correction.hamlet +++ b/templates/correction.hamlet @@ -2,9 +2,9 @@ ^{userCorrection}
    -
    + ^{corrForm}
    - + ^{uploadForm} diff --git a/templates/corrections-upload.hamlet b/templates/corrections-upload.hamlet index 7def9e44d..033eafe7c 100644 --- a/templates/corrections-upload.hamlet +++ b/templates/corrections-upload.hamlet @@ -1,2 +1,2 @@ - + ^{upload} diff --git a/templates/corrections.hamlet b/templates/corrections.hamlet index 766cda831..ae932745a 100644 --- a/templates/corrections.hamlet +++ b/templates/corrections.hamlet @@ -1,5 +1,5 @@
    - + ^{table}