Merge branch 'master' into 'live'

Fix form actions & sheetType refactoring

Closes #223, #222, #213, and #85

See merge request !89

.gitignore

@@ -31,3 +31,4 @@ src/Handler/Course.SnapCustom.hs
 .stack-work-*
 .directory
 tags
+.vscode

.vscode/tasks.json

@@ -1,16 +0,0 @@
-{
-    // See https://go.microsoft.com/fwlink/?LinkId=733558
-    // for the documentation about the tasks.json format
-    "version": "2.0.0",
-    "tasks": [
-        {
-            "label": "echo",
-            "type": "shell",
-            "command": "echo Hello",
-            "group": {
-                "kind": "build",
-                "isDefault": true
-            }
-        }
-    ]
-}

build.sh

@@ -0,0 +1,3 @@
+#!/usr/bin/env bash
+
+exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev

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

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
@@ -351,18 +352,29 @@ MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n
 MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
 
-SheetTypeBonus: Bonus
+SheetGrading: Bewertung
-SheetTypeNormal: Normal
+SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
-SheetTypePass: Bestehen
+SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
-SheetTypeNotGraded: Keine Wertung
+SheetGradingPassBinary:  Bestanden/Nicht Bestanden
+SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. 
 
-SheetTypeBonus' maxPoints@Points: #{tshow maxPoints} Bonuspunkte
+SheetGradingPoints': Punkte
-SheetTypeNormal' maxPoints@Points: #{tshow maxPoints} Punkte
+SheetGradingPassPoints': Bestehen nach Punkten
-SheetTypePass' maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
+SheetGradingPassBinary': Bestanden/Nicht bestanden
-SheetTypeNotGraded': Nicht gewertet
 
-SheetTypeMaxPoints: Maximalpunktzahl
+SheetTypeBonus grading@SheetGrading: Bonus
-SheetTypePassingPoints: Notwendig zum Bestehen
+SheetTypeNormal grading@SheetGrading: Normal
+SheetTypeInformational grading@SheetGrading: Keine Wertung
+SheetTypeNotGraded: Unbewertet
+SheetTypeInfo: Bonus Blätter zählen, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
+
+SheetTypeBonus': Bonus
+SheetTypeNormal': Normal
+SheetTypeInformational': Keine Wertung
+SheetTypeNotGraded': Unbewertet
+
+SheetGradingMaxPoints: Maximalpunktzahl
+SheetGradingPassingPoints: Notwendig zum Bestehen
 
 SheetGroupArbitrary: Arbiträre Gruppen
 SheetGroupRegisteredGroups: Registrierte Gruppen

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:

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,

src/Auth/Dummy.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , TemplateHaskell
-           , FlexibleContexts
-           , TypeFamilies
-           , OverloadedStrings
-  #-}
-
 module Auth.Dummy
   ( dummyLogin
   , DummyMessage(..)

src/Auth/LDAP.hs

@@ -1,14 +1,3 @@
-{-# LANGUAGE RecordWildCards
-           , OverloadedStrings
-           , TemplateHaskell
-           , ViewPatterns
-           , TypeFamilies
-           , FlexibleContexts
-           , FlexibleInstances
-           , NoImplicitPrelude
-           , ScopedTypeVariables
-  #-}
-
 module Auth.LDAP
   ( campusLogin
   , CampusUserException(..)

src/Auth/PWHash.hs

@@ -1,13 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , QuasiQuotes
-           , TemplateHaskell
-           , ViewPatterns
-           , RecordWildCards
-           , OverloadedStrings
-           , FlexibleContexts
-           , TypeFamilies
-  #-}
-
 module Auth.PWHash
   ( hashLogin
   , PWHashMessage(..)

src/Cron.hs

@@ -1,12 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , PatternGuards
-           , ViewPatterns
-           , DeriveFunctor
-           , TemplateHaskell
-           , NamedFieldPuns
-  #-}
-
 module Cron
   ( CronNextMatch(..)
   , nextCronMatch

src/Cron/Types.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , DuplicateRecordFields
-  #-}
-
 module Cron.Types
   ( Cron(..), Crontab
   , CronMatch(..)

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

src/CryptoID/TH.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-}
-
 module CryptoID.TH where
 
 import ClassyPrelude

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
 

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

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

src/Foundation.hs

@@ -1,17 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE UndecidableInstances #-}
-{-# 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 #-}
 
 module Foundation where
 
@@ -235,10 +222,20 @@ 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 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" <>)
@@ -906,7 +903,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
@@ -941,7 +938,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

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

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
 

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
@@ -255,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"
@@ -503,7 +489,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{..})
@@ -552,6 +540,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")
@@ -563,8 +553,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

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)

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
 

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

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

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

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
@@ -61,11 +44,11 @@ import qualified Data.Map as Map
 
 import Data.Monoid (Sum(..), Any(..))
 
-import Control.Lens
+-- import Control.Lens
--- import Utils.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
@@ -119,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)
@@ -183,7 +167,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 $ SheetTypeComplete sheetType
       , sortable Nothing (i18nCell MsgSubmission)
           $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
               Nothing -> mempty
@@ -202,22 +186,37 @@ 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)))
+                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})) ->
-                case sType of
+                case preview (_grading . _maxPoints) sType of
-                  NotGraded -> mempty
+                  (Nothing) -> mempty
-                  _ | maxPoints sType > 0 ->
+                  (Just maxPoints) ->
-                        let percent = sPoints / maxPoints sType
+                        let percent = sPoints / maxPoints
                         in textCell $ textPercent $ realToFrac percent    
-                  _other -> mempty
               _other -> mempty
       ]
     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{..}, _, _) }

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"
+        , dbtSorting = Map.fromList
-                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
+          [ ( "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)))
+          , ( "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 = []
+          ]
+        , dbtFilter = Map.empty
         }
   mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 

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

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"
+        , dbtSorting = Map.fromList
-                         , SortColumn $ \term -> term E.^. TermStart
+            [ ( "start"
-                         )
+              , SortColumn $ \term -> term E.^. TermStart
-                       , ( "end"
+              )
-                         , SortColumn $ \term -> term E.^. TermEnd
+            , ( "end"
-                         )
+              , SortColumn $ \term -> term E.^. TermEnd
-                       , ( "lecture-start"
+              )
-                         , SortColumn $ \term -> term E.^. TermLectureStart
+            , ( "lecture-start"
-                         )
+              , SortColumn $ \term -> term E.^. TermLectureStart
-                       , ( "lecture-end"
+              )
-                         , SortColumn $ \term -> term E.^. TermLectureEnd
+            , ( "lecture-end"
-                         )
+              , SortColumn $ \term -> term E.^. TermLectureEnd
-                       ]
+              )
-        , dbtFilter = [ ( "active"
+            ]
-                        , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
+        , dbtFilter = Map.fromList
-                        )
+            [ ( "active"
-                      , ( "course"
+              , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
-                        , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are 
+              )
-                            []   -> E.val True :: E.SqlExpr (E.Value Bool)
+            , ( "course"
-                            cshs -> E.exists . E.from $ \course -> do
+              , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are 
-                              E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
+                  []   -> E.val True :: E.SqlExpr (E.Value Bool)
-                                   E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
+                  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
         }

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

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

src/Handler/Utils/DateTime.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , OverloadedStrings
-           , RecordWildCards
-           , TypeFamilies
-  #-}
-
 module Handler.Utils.DateTime
   ( utcToLocalTime
   , localTimeToUTC, TZ.LocalToUTCResult(..)

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
@@ -207,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
@@ -282,26 +271,23 @@ multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either
 multiFileField permittedFiles' = Field{..}
   where
     fieldEnctype = Multipart
-    fieldParse vals files
+    fieldParse vals files = return . Right . Just $ do
-      | null files
+      pVals <- lift permittedFiles'
-      , null vals = return $ Right Nothing
+      let
-      | otherwise = return . Right . Just $ do
+        decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
-          pVals <- lift permittedFiles'
+        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt 
-          let
+      yieldMany vals
-            decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
+        .| C.filter (/= unpackZips)
-            decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt 
+        .| C.map fromPathPiece .| C.catMaybes
-          yieldMany vals
+        .| C.mapMaybeM decrypt'
-            .| C.filter (/= unpackZips)
+        .| C.filter (`elem` pVals)
-            .| C.map fromPathPiece .| C.catMaybes
+        .| C.map Left
-            .| C.mapMaybeM decrypt'
+      let
-            .| C.filter (`elem` pVals)
+        handleFile :: FileInfo -> Source Handler File
-            .| C.map Left
+        handleFile
-          let
+          | doUnpack  = sourceFiles
-            handleFile :: FileInfo -> Source Handler File
+          | otherwise = yieldM . acceptFile
-            handleFile
+      mapM_ handleFile files .| C.map Right
-              | doUnpack  = sourceFiles
-              | otherwise = yieldM . acceptFile
-          mapM_ handleFile files .| C.map Right
       where
         doUnpack = unpackZips `elem` vals
     fieldView fieldId fieldName attrs val req = do
@@ -327,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'
@@ -339,14 +341,8 @@ instance PathPiece SheetType' where
   toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
   fromPathPiece = finiteFromPathPiece
 
-instance RenderMessage UniWorX SheetType' where
+embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)  
-  renderMessage f ls = \case
+
-    Bonus' -> render MsgSheetTypeBonus
-    Normal' -> render MsgSheetTypeNormal
-    Pass' -> render MsgSheetTypePass
-    NotGraded' -> render MsgSheetTypeNotGraded
-    where
-      render = renderMessage f ls
 
 data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
@@ -368,44 +364,41 @@ instance RenderMessage UniWorX SheetGroup' where
     where
       render = renderMessage f ls
 
-sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
-sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
+sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
-  let
+  where 
     selOptions = Map.fromList 
-      [ ( Bonus', Bonus <$> maxPointsReq )
+      [ ( Points', Points <$> maxPointsReq )
-      , ( Normal', Normal <$> maxPointsReq )
+      , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
-      , ( Pass', Pass
+      , ( PassBinary', pure PassBinary)
-          <$> maxPointsReq
+      ]
-          <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< 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 )
       ]    
-  (res, selView) <- multiAction selOptions (classify' <$> template)
+    gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
-
+        & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
-  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' :: SheetType -> SheetType'
     classify' = \case
-      Bonus _ -> Bonus'
+      Bonus  {} -> Bonus'
-      Normal _ -> Normal'
+      Normal {} -> Normal'
-      Pass _ _ -> Pass'
+      Informational {} -> Informational'
       NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup

src/Handler/Utils/Form/Types.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Handler.Utils.Form.Types where
 
 import Import

src/Handler/Utils/Mail.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , NamedFieldPuns
-           , TypeFamilies
-           , FlexibleContexts
-           , ViewPatterns
-           , LambdaCase
-  #-}
-
 module Handler.Utils.Mail
   ( addRecipientsDB
   , userMailT

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'(..)
@@ -57,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
@@ -65,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
@@ -131,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)
     , "============================================="

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

src/Handler/Utils/StudyFeatures.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-  #-}
-
 module Handler.Utils.StudyFeatures
   ( parseStudyFeatures
   ) where

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

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

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
 

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
@@ -90,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

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)

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)

src/Handler/Utils/Templates.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, QuasiQuotes #-}
-
 module Handler.Utils.Templates where
 
 import Data.Either (isLeft)

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 #-}
 

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

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

src/Jobs/Crontab.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , FlexibleContexts
-           , MultiWayIf
-           , NamedFieldPuns
-           , TypeFamilies
-  #-}
-
 module Jobs.Crontab
   ( determineCrontab
   ) where

src/Jobs/Handler/HelpRequest.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , RecordWildCards
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.HelpRequest
   ( dispatchJobHelpRequest
   ) where

src/Jobs/Handler/QueueNotification.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-  #-}
-
 module Jobs.Handler.QueueNotification
   ( dispatchJobQueueNotification
   ) where

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
 
 

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.CorrectionsAssigned
   ( dispatchNotificationCorrectionsAssigned
   ) where

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.SheetActive
   ( dispatchNotificationSheetActive
   ) where

src/Jobs/Handler/SendNotification/SheetInactive.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.SheetInactive
   ( dispatchNotificationSheetSoonInactive
   , dispatchNotificationSheetInactive

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.SubmissionRated
   ( dispatchNotificationSubmissionRated
   ) where
@@ -32,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
@@ -46,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

src/Jobs/Handler/SendTestEmail.hs

@@ -1,14 +1,8 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , QuasiQuotes
-  #-}
-
 module Jobs.Handler.SendTestEmail
   ( dispatchJobSendTestEmail
   ) where
 
-import Import hiding ((.=))
+import Import 
 
 import Handler.Utils.DateTime
 

src/Jobs/Handler/SetLogSettings.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-  #-}
-
 module Jobs.Handler.SetLogSettings
   ( dispatchJobSetLogSettings
   ) where

src/Jobs/Queue.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TypeFamilies
-  #-}
-
 module Jobs.Queue
   ( writeJobCtl, writeJobCtlBlock
   , queueJob, queueJob'

src/Jobs/TH.hs

@@ -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

src/Jobs/Types.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE TemplateHaskell
-           , NoImplicitPrelude
-           , DeriveGeneric
-           , DeriveDataTypeable
-  #-}
-
 module Jobs.Types
   ( Job(..), Notification(..)
   , JobCtl(..)

src/Mail.hs

@@ -1,22 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude
+{-# LANGUAGE GeneralizedNewtypeDeriving
-           , GeneralizedNewtypeDeriving
-           , DerivingStrategies
-           , FlexibleInstances
-           , MultiParamTypeClasses
            , UndecidableInstances
-           , DeriveGeneric
-           , TemplateHaskell
-           , OverloadedStrings
-           , RecordWildCards
-           , FlexibleContexts
-           , TypeFamilies
-           , ViewPatterns
-           , NamedFieldPuns
-           , MultiWayIf
-           , QuasiQuotes
-           , RankNTypes
-           , ScopedTypeVariables
-           , DeriveDataTypeable
   #-}
 
 module Mail

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
@@ -45,11 +32,5 @@ 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

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
@@ -16,6 +8,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 +189,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]                
+    )
   ]
 
 

src/Model/Migration/Types.hs

@@ -0,0 +1,33 @@
+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
+  | 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 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
+Current.derivePersistFieldJSON ''SheetType

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

src/Model/Types.hs

@@ -1,16 +1,6 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving
-{-# LANGUAGE PatternGuards #-}
+           , UndecidableInstances
-{-# 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
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
 module Model.Types
@@ -123,45 +113,78 @@ fromPoints = round
 
 instance DisplayAble Points
 
+
+data SheetGrading
+  = Points     { maxPoints :: Points }
+  | PassPoints { maxPoints, passingPoints :: Points }
+  | PassBinary -- non-zero means passed
+  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
+
+gradingPassed :: SheetGrading -> Points -> Maybe Bool
+gradingPassed (Points {}) _ = Nothing
+gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
+gradingPassed (PassBinary {}) pts = Just $ pts /= 0
+
+data SheetGradeSummary = SheetGradeSummary 
+  { sumGradePoints :: Sum Points
+  , numGradePasses :: Sum Int
+  , achievedPoints :: Maybe (Sum Points)
+  , achievedPasses :: Maybe (Sum Int)
+} deriving (Generic)
+
+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  { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
+  = Normal        { grading :: SheetGrading }
-  | Normal { maxPoints :: Points } -- Erhöht das Maximum, wird gutgeschrieben
+  | Bonus         { grading :: SheetGrading }
---  | Informational { maxPoints :: Points } -- Erhöht nicht das Maximum Keine Gutschrift
+  | Informational { grading :: SheetGrading }
-  | Pass   { maxPoints, passingPoints :: Points }
   | NotGraded
-  deriving (Show, Read, Eq)
+  deriving (Eq, Read, Show) 
 
-instance DisplayAble SheetType where
+deriveJSON defaultOptions
-  display (Bonus {..}) = tshow maxPoints <> " Bonuspunkte"
+  { constructorTagModifier = intercalate "-" . map toLower . splitCamel
-  display (Normal{..}) = tshow maxPoints <> " Punkte"
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  display (Pass  {..}) = "Bestanden ab " <> tshow (pToI passingPoints) <> " von " <> tshow maxPoints
+  , sumEncoding = TaggedObject "type" "data"  
-  display (NotGraded)  = "Unbewertet"
+  } ''SheetType
-
-deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON ''SheetType
 
-makeLenses_ ''SheetType
-
 data SheetTypeSummary = SheetTypeSummary
-  { sumBonusPoints  :: Sum Points
+  { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary
-  , sumNormalPoints :: Sum Points
+  , numNotGraded  :: Sum Int
-  , numPassSheets   :: Sum Int
-  , numNotGraded    :: Sum Int
-  , achievedBonus   :: Maybe (Sum Points)
-  , achievedNormal  :: Maybe (Sum Points)
-  , achievedPasses  :: Maybe (Sum Int)
   } deriving (Generic)
 
 instance Monoid SheetTypeSummary where
-  mempty = memptydefault
+  mempty  = memptydefault
   mappend = mappenddefault
 
-sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
+sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
-sheetTypeSum (Bonus{..},  achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }
+sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps } 
-sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved }
+sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps } 
-sheetTypeSum (Pass{..},   achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved}
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } 
-sheetTypeSum (NotGraded,  _       ) = mempty { numNotGraded = Sum 1 }
+sheetTypeSum NotGraded _           = mempty { numNotGraded = Sum 1 }
-
 
 data SheetGroup
   = Arbitrary { maxParticipants :: Natural }

src/Model/Types/JSON.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
-
 module Model.Types.JSON
   ( derivePersistFieldJSON
   ) where

src/Model/Types/Wordlist.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , ViewPatterns
-           , OverloadedStrings
-  #-}
-
 module Model.Types.Wordlist (wordlist) where
 
 import ClassyPrelude hiding (lift)

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

src/Settings/Cluster.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , DataKinds
-           , TypeFamilies
-           , ScopedTypeVariables
-           , TemplateHaskell
-           , OverloadedStrings
-           , FlexibleContexts
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Settings.Cluster

src/Settings/StaticFiles.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
 module Settings.StaticFiles where
 
 import Settings     (appStaticDir, compileTimeAppSettings)

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
@@ -17,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
@@ -311,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
 

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

src/Utils/DateTime.hs

@@ -1,15 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-           , TemplateHaskell
-           , QuasiQuotes
-           , StandaloneDeriving
-           , DerivingStrategies
-           , DeriveLift
-           , DeriveDataTypeable
-           , DeriveGeneric
-           , GeneralizedNewtypeDeriving
-           , OverloadedStrings
-           , FlexibleInstances
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Utils.DateTime

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)

src/Utils/Lang.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 module Utils.Lang where
 
 import ClassyPrelude.Yesod

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
@@ -29,6 +24,10 @@ makeLenses_ ''SheetCorrector
 
 makeLenses_ ''SubmissionGroup
 
+makeLenses_ ''SheetGrading
+
+makeLenses_ ''SheetType
+
 -- makeClassy_ ''Load
 
 

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

src/Utils/PathPiece.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-  #-}
-
 module Utils.PathPiece
   ( finiteFromPathPiece
   , nullaryToPathPiece

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

src/Utils/SystemMessage.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-  #-}
-
 module Utils.SystemMessage where
 
 import Import.NoFoundation

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

templates/correction-user.hamlet

@@ -11,28 +11,34 @@
       <tr .table__row>
         <th .table__th>_{MsgRatingTime}
         <td .table__td>^{formatTimeW SelFormatDateTime time}
+    
     $maybe points <- submissionRatingPoints
-      $case sheetType
+      $maybe grading <- preview _grading sheetType
-        $of Bonus{..}
+        $case grading 
-          <tr .table__row>
+          $of Points{..}
-            <th .table__th>_{MsgAchievedBonusPoints}
+            <tr .table__row>
-            <td .table__td>_{MsgAchievedOf points maxPoints}
+              <th .table__th>#{sheetTypeDesc}
-        $of Normal{..}
+              <td .table__td>_{MsgAchievedOf points maxPoints}
-          <tr .table__row>
+          $of PassPoints{..}
-            <th .table__th>_{MsgAchievedNormalPoints}
+            <tr .table__row>
-            <td .table__td>_{MsgAchievedOf points maxPoints}
+              <th .table__th>#{sheetTypeDesc}
-        $of Pass{..}
+              <td .table__td>
-          <tr .table__row>
+                $if fromMaybe False (gradingPassed grading points)
-            <th .table__th>_{MsgPassedResult}
+                  _{MsgPassed}
-            <td .table__td>
+                $else
-              $if points >= passingPoints
+                  _{MsgNotPassed}
-                _{MsgPassed}
+            <tr .table__row>
-              $else
+              <th .table__th>_{MsgAchievedPassPoints}
-                _{MsgNotPassed}
+              <td .table__td>_{MsgPassAchievedOf points passingPoints maxPoints}
-          <tr .table__row>
+          $of PassBinary
-            <th .table__th>_{MsgAchievedPassPoints}
+            <tr .table__row>
-            <td .table__td>_{MsgPassAchievedOf points passingPoints maxPoints}
+              <th .table__th>#{sheetTypeDesc}
-        $of NotGraded
+              <td .table__td>
+                $if fromMaybe False (gradingPassed grading points)
+                  _{MsgPassed}
+                $else
+                  _{MsgNotPassed}
+
     $maybe comment <- ratingComment
       <tr .table__row>
         <th .table__th>_{MsgRatingComment}

templates/correction.hamlet

@@ -2,9 +2,9 @@
   ^{userCorrection}
 
 <section> 
-  <form method=post enctype=#{corrEncoding}>
+  <form method=post enctype=#{corrEncoding} action=@{CSubmissionR tid ssh csh shn cid CorrectionR}>
     ^{corrForm}
 
 <section>
-  <form method=post enctype=#{uploadEncoding}>
+  <form method=post enctype=#{uploadEncoding} action=@{CSubmissionR tid ssh csh shn cid CorrectionR}>
     ^{uploadForm}

templates/corrections-upload.hamlet

@@ -1,2 +1,2 @@
-<form method=POST enctype=#{uploadEncoding}>
+<form method=POST enctype=#{uploadEncoding} action=@{CorrectionsUploadR}>
   ^{upload}

templates/corrections.hamlet

@@ -1,5 +1,5 @@
 <div .container>
-  <form method=POST enctype=#{tableEncoding}>
+  <form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
     ^{table}
     <button type=submit>
       _{MsgBtnSubmit}

templates/mail/submissionRated.hamlet

@@ -33,31 +33,30 @@ $newline never
           _{MsgRatingTime}
         <dd>
           #{time}
+      <dt> #{sheetTypeDesc}
       $maybe points <- submissionRatingPoints
-        $case sheetType
+        $maybe grading <- preview _grading sheetType
-          $of Bonus{..}
+          $case grading 
-            <dt>
+            $of Points{..}
-              _{MsgAchievedBonusPoints}
+              <dd>
-            <dd>
+                _{MsgAchievedOf points maxPoints}          
-              _{MsgAchievedOf points maxPoints}
+            $of PassPoints{..}
-          $of Normal{..}
+              <dd>
-            <dt>
+                $if fromMaybe False (gradingPassed grading points)
-              _{MsgAchievedNormalPoints}
+                  _{MsgPassed}
-            <dd>
+                $else
-              _{MsgAchievedOf points maxPoints}
+                  _{MsgNotPassed}
-          $of Pass{..}
+              <dt>
-            <dt>
+                _{MsgAchievedPassPoints}
-              _{MsgPassedResult}
+              <dd>
-            <dd>
+                _{MsgPassAchievedOf points passingPoints maxPoints}
-              $if points >= passingPoints
+            $of PassBinary
-                _{MsgPassed}
+              <dd>
-              $else
+                $if fromMaybe False (gradingPassed grading points)
-                _{MsgNotPassed}
+                  _{MsgPassed}
-            <dt>
+                $else
-              _{MsgAchievedPassPoints}
+                  _{MsgNotPassed}
-            <dd>
+              
-              _{MsgPassAchievedOf points passingPoints maxPoints}
-          $of NotGraded
       $maybe comment <- submissionRatingComment
         <dt>
           _{MsgRatingComment}

templates/sheetShow.hamlet

@@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
       <dt .deflist__dt>_{MsgSheetSolutionFrom}
       <dd .deflist__dd>#{solution}
     <dt .deflist__dt>_{MsgSheetType}
-    <dd .deflist__dd>_{sheetType sheet}
+    <dd .deflist__dd>_{SheetTypeComplete (sheetType sheet)}
     $if CorrectorSubmissions == sheetSubmissionMode sheet
       <dt .deflist__dt>_{MsgSheetPseudonym}
       <dd .deflist__dd #pseudonym>

templates/widgets/rating.hamlet

@@ -2,15 +2,19 @@ $# Display Rating, expects
 $#  submissionRatingPoints :: Maybe points
 
 $maybe points <- submissionRatingPoints
-  $case sheetType
+  $maybe grading <- preview _grading sheetType
-    $of Bonus{..}
+    $case grading	
-      _{MsgAchievedOf points maxPoints}
+      $of Points{..}
-    $of Normal{..}
+        _{MsgAchievedOf points maxPoints}          
-      _{MsgAchievedOf points maxPoints}
+      $of PassPoints{..}
-    $of Pass{..}
+        $if fromMaybe False (gradingPassed grading points)
-      $if points >= passingPoints
+          _{MsgPassed}
-        _{MsgPassed}
+        $else
-      $else
+          _{MsgNotPassed}
-        _{MsgNotPassed}
+      $of PassBinary 
-    $of NotGraded
+        $if fromMaybe False (gradingPassed grading points)
-        #{display tickmarkS}
+          _{MsgPassed}
+        $else
+          _{MsgNotPassed}
+  $nothing
+    #{tickmarkS}

templates/widgets/sheetTypeSummary.hamlet

@@ -1,23 +1,38 @@
-<div>
+$with realGrades <- normalSummary <> bonusSummary 
-  $if 0 < getSum sumNormalPoints
+  $with allGrades <- realGrades <> informationalSummary
-    Gesamtpunktzahl #{display (getSum sumNormalPoints)}
+    <div>
-    $maybe nPts <- (maybeAdd (getSum <$> achievedNormal) (getSum <$> achievedBonus))
+      <ul>    
-      \ davon #{display nPts} erreicht
+        $maybe realPoints <- positiveSum (sumGradePoints realGrades) 
-      $maybe bPts <- getSum <$> achievedBonus
+          <li>     
-        \ (inklusive #{display bPts} #
+            Gesamtpunktzahl #{display realPoints}
-        $if 0 < getSum sumBonusPoints
+            $maybe nPts <- getSum <$> achievedPoints realGrades
-          von #{display $ getSum sumBonusPoints} erreichbaren #
+              \ davon #{display nPts} erreicht
-        Bonuspunkten)
+              $maybe bPts <- getSum <$> achievedPoints bonusSummary
-      \ #{textPercent $ realToFrac $ nPts / (getSum sumNormalPoints)}
+                \ (inklusive #{display bPts} #
+                $maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary)
+                  von #{display achievedBonus} erreichbaren #
+                Bonuspunkten)
+              \ #{textPercent $ realToFrac $ nPts / realPoints}    
+        $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
+          <li>
+            <em>Hinweis: 
+            \ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
+            welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
+            $maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
+              , davon wurden #{display achievedFakes} erreicht
+              \ #{textPercent $ realToFrac $ achievedFakes / fakePoints}    
+            .
       
+        $maybe reqPasses <- positiveSum (numGradePasses normalSummary)      
+          <li>
+            Aufgaben zum Bestehen: #{display reqPasses}
+            $maybe passed <- getSum <$> achievedPasses realGrades
+              \ davon #{display passed} bestanden
+              $maybe bonusPassed <- getSum <$> achievedPasses bonusSummary
+                \ (inklusive #{display bonusPassed} Bonusaufgaben)
+              .
       
-<div>
+        $maybe noGradeSheets <- positiveSum numNotGraded
-  $if 0 < getSum numPassSheets
+          <li>
-    Blätter zum Bestehen: #{display (getSum numPassSheets)}
+            #{display noGradeSheets} unbewertete Aufgabenblätter.
-    $maybe passed <- getSum <$> achievedPasses
-      \ davon #{display passed} bestanden.
-
-<div>
-  $if 0 < getSum numNotGraded
-    Unbewertet: #{display (getSum numNotGraded)} Blätter