Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

2018-11-20 15:49:10 +03:00 · 2018-11-20 15:49:10 +03:00 · 5a4ef4e13c
commit 5a4ef4e13c
parent b0732ae6c6 5116b6b380
16 changed files with 144 additions and 162 deletions
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@ -338,10 +338,12 @@ UploadModeNone: Kein Upload
 UploadModeUnpack: Upload, einzelne Datei
 UploadModeNoUnpack: Upload, ZIP-Archive entpacken

-SheetNoSubmission: Keine Abgabe
-SheetCorrectorSubmissions: Abgaben durch Korrektoren
+SheetNoSubmissions: Keine Abgabe
+SheetCorrectorSubmissions: Abgabe extern mit Pseudonym
 SheetUserSubmissions: Direkte Abgabe

+SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2Work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2Work eintragen, damit Sie sie einsehen können.
+
 SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.

 FieldPrimary: Hauptfach
@ -431,7 +433,7 @@ UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht!
 HelpAnswer: Antworten an
 HelpUser: Meinen Benutzeraccount
 HelpAnonymous: Keine Antwort (Anonym)
-HelpEMail: E-Mail
+HelpEmail: E-Mail
 HelpRequest: Supportanfrage / Verbesserungsvorschlag
 HelpProblemPage: Problematische Seite
 HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@ -202,11 +202,20 @@ embedRenderMessage ''UniWorX ''CorrectorState id
 embedRenderMessage ''UniWorX ''RatingException id
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
 embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
+embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)

 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)

-instance RenderMessage UniWorX (SheetType) where
+instance RenderMessage UniWorX UploadMode where
+  renderMessage foundation ls uploadMode = case uploadMode of
+    NoUpload     -> mr MsgUploadModeNone
+    Upload False -> mr MsgUploadModeNoUnpack
+    Upload True  -> mr MsgUploadModeUnpack
+    where
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX SheetType where
  renderMessage foundation ls sheetType = case sheetType of
      NotGraded -> mr $ SheetTypeHeader NotGraded
      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
@ -532,10 +541,7 @@ data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 instance Universe SessionAuthTags
 instance Finite SessionAuthTags
-$(return [])
-instance PathPiece SessionAuthTags where
-  toPathPiece = $(nullaryToPathPiece ''SessionAuthTags [intercalate "-" . map toLower . splitCamel])
-  fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)

 routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
 -- ^ DNF up to entailment:
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@ -517,31 +517,32 @@ postCorrectionR tid ssh csh shn cid = do
      case corrResult of
        FormMissing -> return ()
        FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-        FormSuccess (rated, ratingPoints', ratingComment')
-          | errs <- validateRating sheetType Rating'
-                      { ratingPoints=ratingPoints'
-                      , ratingComment=ratingComment'
-                      , ratingTime=Nothing
-                      }
-            -> mapM_ (addMessageI Error) errs
-          | otherwise -> do
-            runDBJobs $ do
-              uid <- liftHandlerT requireAuthId
-              now <- liftIO getCurrentTime
+        FormSuccess (rated, ratingPoints', ratingComment') -> do
+          uid <- liftHandlerT requireAuthId
+          now <- liftIO getCurrentTime

-              update sub  [ SubmissionRatingBy      =. Just uid
-                          , SubmissionRatingTime    =. (now <$ guard rated)
-                          , SubmissionRatingPoints  =. ratingPoints'
-                          , SubmissionRatingComment =. ratingComment'
-                          ]
+          if
+            | errs <- validateRating sheetType Rating'
+                        { ratingPoints  = ratingPoints'
+                        , ratingComment = ratingComment'
+                        , ratingTime    = (now <$ guard rated)
+                        }
+            , not $ null errs
+              -> mapM_ (addMessageI Error) errs
+            | otherwise -> runDBJobs $ do
+                update sub  [ SubmissionRatingBy      =. Just uid
+                            , SubmissionRatingTime    =. (now <$ guard rated)
+                            , SubmissionRatingPoints  =. ratingPoints'
+                            , SubmissionRatingComment =. ratingComment'
+                            ]

-              addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
+                addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated

-              when (rated && isNothing submissionRatingTime) $ do
-                $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
-                queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
+                when (rated && isNothing submissionRatingTime) $ do
+                  $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
+                  queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub

-            redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
+          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR

      case uploadResult of
        FormMissing -> return ()
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@ -5,9 +5,7 @@ import Handler.Utils

 import qualified Data.Map as Map

-import qualified Data.Text as Text
 import Data.Time hiding (formatTime)
-import Data.Universe.Helpers

 -- import qualified Data.Text as T
 -- import Yesod.Form.Bootstrap3
@ -226,19 +224,11 @@ getVersionR = selectRep $ do
 data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
  deriving (Eq, Ord, Bounded, Enum, Show, Read)

-$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
-instance Universe HelpIdentOptions where universe = universeDef
+instance Universe HelpIdentOptions
 instance Finite HelpIdentOptions

-instance PathPiece HelpIdentOptions where
-  toPathPiece   = $(nullaryToPathPiece ''HelpIdentOptions [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
-  fromPathPiece = finiteFromPathPiece
-
-instance RenderMessage UniWorX HelpIdentOptions where
-  renderMessage foundation ls = renderMessage foundation ls . \case 
-    HIUser      -> MsgHelpUser 
-    HIEmail     -> MsgHelpEMail
-    HIAnonymous -> MsgHelpAnonymous
+nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
+embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")

 data HelpForm = HelpForm
  { hfReferer:: Maybe (Route UniWorX)
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@ -246,11 +246,7 @@ data ButtonGeneratePseudonym = BtnGenerate
 instance Universe ButtonGeneratePseudonym
 instance Finite ButtonGeneratePseudonym

-$(return [])
-
-instance PathPiece ButtonGeneratePseudonym where
-  toPathPiece = $(nullaryToPathPiece ''ButtonGeneratePseudonym [Text.unwords . drop 1 . splitCamel])
-  fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)

 instance Button UniWorX ButtonGeneratePseudonym where
  label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
@ -674,7 +670,7 @@ correctorForm shid = do
          }
        rationalField = convertField toRational fromRational doubleField

-      (stateRes, cfViewState) <- mreq (selectField $ optionsFinite id) (fs "state") (Just state)
+      (stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
      (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@ -37,7 +37,7 @@ postMessageR cID = do
          <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
          <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
          <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
-          <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
+          <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
          <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage)
          <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent)
          <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary)
@ -139,16 +139,9 @@ data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate
  deriving (Eq, Ord, Enum, Bounded, Show, Read)
 instance Universe ActionSystemMessage
 instance Finite ActionSystemMessage
-$(return [])
-instance PathPiece ActionSystemMessage where
-  toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ])
-  fromPathPiece = finiteFromPathPiece

-instance RenderMessage UniWorX ActionSystemMessage where
-  renderMessage m ls = renderMessage m ls . \case
-    SMDelete -> MsgSystemMessageDelete
-    SMActivate -> MsgSystemMessageActivate
-    SMDeactivate -> MsgSystemMessageDeactivate
+nullaryPathPiece ''ActionSystemMessage (camelToPathPiece' 1)
+embedRenderMessage ''UniWorX ''ActionSystemMessage (("SystemMessage" <>) . dropPrefix "SM")

 data ActionSystemMessageData = SMDDelete
                             | SMDActivate (Maybe UTCTime)
@ -234,7 +227,7 @@ postMessageListR = do
    <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
    <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
    <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
-    <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) Nothing
+    <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
    <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages)
    <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
    <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -41,8 +41,6 @@ import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)

-import Data.Maybe (fromJust)
-
 import Utils.Lens

 ----------------------------
@ -102,11 +100,7 @@ instance Button UniWorX BtnSubmitDelete where
  cssClass BtnSubmit' = BCPrimary
  cssClass BtnDelete' = BCDanger

-$(return [])
-
-instance PathPiece BtnSubmitDelete where
-  toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ])
-  fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''BtnSubmitDelete (camelToPathPiece' 1 . dropSuffix "'")


 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
@ -230,18 +224,10 @@ schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName

 uploadModeField :: Field Handler UploadMode
-uploadModeField = selectFieldList
-  [ (MsgUploadModeNone    , NoUpload      )
-  , (MsgUploadModeNoUnpack, Upload   False)
-  , (MsgUploadModeUnpack  , Upload   True )
-  ]
+uploadModeField = selectField optionsFinite

 submissionModeField :: Field Handler SheetSubmissionMode
-submissionModeField = selectFieldList
-  [ (MsgSheetNoSubmission, NoSubmissions)
-  , (MsgSheetCorrectorSubmissions, CorrectorSubmissions)
-  , (MsgSheetUserSubmissions, UserSubmissions)
-  ]
+submissionModeField = selectField optionsFinite

 pseudonymWordField :: Field Handler PseudonymWord
 pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
@ -320,12 +306,7 @@ data SheetGrading' = Points' | PassPoints' | PassBinary'
 instance Universe SheetGrading'
 instance Finite SheetGrading'

-$(return [])
-
-instance PathPiece SheetGrading' where
-  toPathPiece = $(nullaryToPathPiece ''SheetGrading' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
-  fromPathPiece = finiteFromPathPiece
-
+nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
 embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)  


@ -335,12 +316,7 @@ data SheetType' = Bonus' | Normal' | Informational' | NotGraded'
 instance Universe SheetType'
 instance Finite SheetType'

-$(return [])
-
-instance PathPiece SheetType' where
-  toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
-  fromPathPiece = finiteFromPathPiece
-
+nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
 embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)  


@ -350,19 +326,8 @@ data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
 instance Universe SheetGroup'
 instance Finite SheetGroup'

-$(return [])
-
-instance PathPiece SheetGroup' where
-  toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
-  fromPathPiece = finiteFromPathPiece
-
-instance RenderMessage UniWorX SheetGroup' where
-  renderMessage f ls = \case
-    Arbitrary' -> render MsgSheetGroupArbitrary
-    RegisteredGroups' -> render MsgSheetGroupRegisteredGroups
-    NoGroups' -> render MsgSheetGroupNoGroups
-    where
-      render = renderMessage f ls
+nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
+embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")

 sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
 sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
@ -543,18 +508,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
                 , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                 }) cPairs

-optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a )
-              => (a -> msg) -> m (OptionList a)
-optionsFinite toMsg = do
-  mr <- getMessageRender
-  let
-    mkOption a = Option
-      { optionDisplay       = mr $ toMsg a
-      , optionInternalValue = a
-      , optionExternalValue = toPathPiece a
-      }
-  return . mkOptionList $ mkOption <$> universeF
-
 mforced :: (site ~ HandlerSite m, MonadHandler m)
        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
 mforced Field{..} FieldSettings{..} val = do
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@ -12,7 +12,7 @@ module Model.Types

 import ClassyPrelude
 import Utils
-import Control.Lens
+import Control.Lens hiding (universe)
 import Utils.Lens.TH

 import Data.Set (Set)
@ -260,16 +260,32 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool }
 deriveJSON defaultOptions ''UploadMode
 derivePersistFieldJSON ''UploadMode

+instance Universe UploadMode where
+  universe = NoUpload : (Upload <$> universe)
+instance Finite UploadMode
+
+instance PathPiece UploadMode where
+  toPathPiece = \case
+    NoUpload     -> "no-upload"
+    Upload True  -> "unpack"
+    Upload False -> "no-unpack"
+  fromPathPiece = finiteFromPathPiece
+
 data SheetSubmissionMode = NoSubmissions
                         | CorrectorSubmissions
                         | UserSubmissions
  deriving (Show, Read, Eq, Ord, Enum, Bounded)

 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . splitCamel
+  { constructorTagModifier = camelToPathPiece
  } ''SheetSubmissionMode
 derivePersistField "SheetSubmissionMode"

+instance Universe SheetSubmissionMode
+instance Finite SheetSubmissionMode
+
+nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
+
 data ExamStatus = Attended | NoShow | Voided
  deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "ExamStatus"
@ -447,14 +463,10 @@ deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Theme"
  } ''Theme

-$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
-
 instance Universe Theme where universe = universeDef
 instance Finite Theme

-instance PathPiece Theme where
-  toPathPiece   = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
-  fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''Theme (camelToPathPiece' 1)

 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user

@ -472,8 +484,6 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

-$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
-
 deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Corrector"
  } ''CorrectorState
@ -481,9 +491,7 @@ deriveJSON defaultOptions
 instance Universe CorrectorState where universe = universeDef
 instance Finite CorrectorState

-instance PathPiece CorrectorState where
-  toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map toLower . unsafeTail . splitCamel])
-  fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)

 derivePersistField "CorrectorState"

@ -669,12 +677,10 @@ instance Finite AuthTag
 instance Hashable AuthTag

 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  { constructorTagModifier = camelToPathPiece' 1
  } ''AuthTag

-instance PathPiece AuthTag where
-  toPathPiece = $(nullaryToPathPiece ''AuthTag [Text.intercalate "-" . map toLower . drop 1 . splitCamel])
-  fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''AuthTag (camelToPathPiece' 1)

 instance ToJSONKey AuthTag where
  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@ -42,15 +42,11 @@ data ClusterSettingsKey
 instance Universe ClusterSettingsKey
 instance Finite ClusterSettingsKey

-$(return [])
-
-instance PathPiece ClusterSettingsKey where
-  toPathPiece = $(nullaryToPathPiece ''ClusterSettingsKey [intercalate "-" . map toLower . drop 1 . splitCamel])
-  fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''ClusterSettingsKey (camelToPathPiece' 1)

 deriveJSON
  defaultOptions
-    { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    { constructorTagModifier = camelToPathPiece' 1
    }
  ''ClusterSettingsKey

--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@ -9,6 +9,7 @@ import qualified Data.Char as Char

 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
+import Data.Universe

 import Data.Map.Lazy ((!))
 import qualified Data.Map.Lazy as Map
@ -272,6 +273,24 @@ reorderField optList = Field{..}
        withNum t n = tshow n <> "." <> t
      $(widgetFile "widgets/permutation")

+optionsFinite :: ( MonadHandler m
+                 , Finite a
+                 , RenderMessage site a
+                 , HandlerSite m ~ site
+                 , PathPiece a
+                 )
+              => m (OptionList a)
+optionsFinite = do
+  mr <- getMessageRender
+  let
+    mkOption a = Option
+      { optionDisplay       = mr a
+      , optionInternalValue = a
+      , optionExternalValue = toPathPiece a
+      }
+  return . mkOptionList $ mkOption <$> universeF
+
+
 ---------------------
 -- Form evaluation --
 ---------------------
--- a/src/Utils/Message.hs
+++ b/src/Utils/Message.hs
@ -5,7 +5,7 @@ module Utils.Message


 import Data.Universe
-import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
+import Utils.PathPiece
 import Data.Aeson
 import Data.Aeson.TH

@ -24,16 +24,11 @@ data MessageClass = Error | Warning | Info | Success
 instance Universe MessageClass
 instance Finite   MessageClass

-$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
-
 deriveJSON defaultOptions
-  { constructorTagModifier = toLower
+  { constructorTagModifier = camelToPathPiece
  } ''MessageClass

-instance PathPiece MessageClass where
-  toPathPiece   = $(nullaryToPathPiece ''MessageClass [toLower])
-  fromPathPiece = finiteFromPathPiece
-
+nullaryPathPiece ''MessageClass camelToPathPiece
 derivePersistField "MessageClass"


--- a/src/Utils/PathPiece.hs
+++ b/src/Utils/PathPiece.hs
@ -1,7 +1,9 @@
 module Utils.PathPiece
  ( finiteFromPathPiece
  , nullaryToPathPiece
+  , nullaryPathPiece
  , splitCamel
+  , camelToPathPiece, camelToPathPiece'
  ) where

 import ClassyPrelude.Yesod
@ -13,15 +15,15 @@ import Data.Universe
 import qualified Data.Text as Text
 import qualified Data.Char as Char

-import Data.Monoid (Endo(..))
+import Numeric.Natural

 finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
 finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
  [x] -> Just x
  _xs -> Nothing

-nullaryToPathPiece :: Name -> [Text -> Text] -> ExpQ
-nullaryToPathPiece nullaryType manglers = do
+nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
+nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do
  TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
  helperName <- newName "helper"
  let
@ -29,8 +31,15 @@ nullaryToPathPiece nullaryType manglers = do
    toClause con = fail $ "Unsupported constructor: " ++ show con
    helperDec = funD helperName $ map toClause constructors
  letE [helperDec] $ varE helperName
-  where
-    mangle = appEndo (foldMap Endo manglers) . Text.pack
+
+nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
+nullaryPathPiece nullaryType mangle =
+  pure <$> instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
+    [ funD 'toPathPiece
+      [ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ]
+    , funD 'fromPathPiece
+      [ clause [] (normalB [e|finiteFromPathPiece|]) [] ]
+    ]
  
 splitCamel :: Textual t => t -> [t]
 splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
@ -48,3 +57,9 @@ splitCamel = map fromList . reverse . helper (error "hasChange undefined at star
      | otherwise        = helper True (reverse ws :items) [c] cs

    sameCategory = (==) `on` Char.generalCategory
+
+camelToPathPiece' :: Textual t => Natural -> t -> t
+camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dropN) . splitCamel
+
+camelToPathPiece :: Textual t => t -> t
+camelToPathPiece = camelToPathPiece' 0
--- a/templates/default-layout-wrapper.hamlet
+++ b/templates/default-layout-wrapper.hamlet
@ -12,7 +12,7 @@ $newline never

    ^{pageHead pc}

-  <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
+  <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in :isModal:.modal>
    <!-- removes no-js class from body if client supports javascript -->
    <script>
      document.body.classList.remove('no-js');
--- a/templates/default-layout.lucius
+++ b/templates/default-layout.lucius
@ -199,7 +199,7 @@ h4 {
 }

@media (max-width: 768px) {
-  .logged-in {
+  .logged-in:not(.modal) {
    .main__content {
      padding-left: 60px;
    }
@ -207,7 +207,7 @@ h4 {
 }

@media (max-width: 425px) {
-  .logged-in {
+  .logged-in:not(.modal) {
    .main__content {
      padding-left: 0;
    }
@ -215,7 +215,7 @@ h4 {
 }

@media (min-width: 769px) {
-  .logged-in {
+  .logged-in:not(.modal) {
    .main__content {
      padding-left: calc(24% + 30px);
    }
@ -223,7 +223,7 @@ h4 {
 }

@media (min-width: 1200px) {
-  .logged-in {
+  .logged-in:not(.modal) {
    .main__content {
      padding-left: 320px;
    }
--- a/templates/sheetShow.hamlet
+++ b/templates/sheetShow.hamlet
@ -19,14 +19,24 @@ $maybe descr <- sheetDescription sheet
      <dd .deflist__dd>#{solution}
    <dt .deflist__dt>_{MsgSheetType}
    <dd .deflist__dd>_{sheetType sheet}
-    $if CorrectorSubmissions == sheetSubmissionMode sheet
-      <dt .deflist__dt>_{MsgSheetPseudonym}
-      <dd .deflist__dd #pseudonym>
-        $maybe pseudonym <- mPseudonym
-          <span .pseudonym>#{pseudonym}
-        $nothing
-          <form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}>
-            ^{generateWidget}
+    <dt .deflist__dt>_{MsgSheetSubmissionMode}
+    <dd .deflist__dd>_{sheetSubmissionMode sheet}
+      $case sheetSubmissionMode sheet
+        $of CorrectorSubmissions
+          <div .js-tooltip>
+            <div .tooltip__handle>
+            <div .tooltip__content>_{MsgSheetCorrectorSubmissionsTip}
+        $of _
+    $case sheetSubmissionMode sheet
+      $of CorrectorSubmissions
+        <dt .deflist__dt>_{MsgSheetPseudonym}
+        <dd .deflist__dd #pseudonym>
+          $maybe pseudonym <- mPseudonym
+            <span .pseudonym>#{pseudonym}
+          $nothing
+            <form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}>
+              ^{generateWidget}
+      $of _

 $if hasFiles
  <section>
--- a/templates/standalone/modal.lucius
+++ b/templates/standalone/modal.lucius
@ -1,4 +1,4 @@
-.modal {
+div.modal {
  position: fixed;
  left: 50%;
  top: 50%;