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

messages/uniworx/de.msg

@@ -338,10 +338,12 @@ UploadModeNone: Kein Upload
 UploadModeUnpack: Upload, einzelne Datei
 UploadModeNoUnpack: Upload, ZIP-Archive entpacken
 
-SheetNoSubmission: Keine Abgabe
+SheetNoSubmissions: Keine Abgabe
-SheetCorrectorSubmissions: Abgaben durch Korrektoren
+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.

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 [])
+nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
-instance PathPiece SessionAuthTags where
-  toPathPiece = $(nullaryToPathPiece ''SessionAuthTags [intercalate "-" . map toLower . splitCamel])
-  fromPathPiece = finiteFromPathPiece
 
 routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
 -- ^ DNF up to entailment:

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')
+        FormSuccess (rated, ratingPoints', ratingComment') -> do
-          | errs <- validateRating sheetType Rating'
+          uid <- liftHandlerT requireAuthId
-                      { ratingPoints=ratingPoints'
+          now <- liftIO getCurrentTime
-                      , ratingComment=ratingComment'
-                      , ratingTime=Nothing
-                      }
-            -> mapM_ (addMessageI Error) errs
-          | otherwise -> do
-            runDBJobs $ do
-              uid <- liftHandlerT requireAuthId
-              now <- liftIO getCurrentTime
 
-              update sub  [ SubmissionRatingBy      =. Just uid
+          if
-                          , SubmissionRatingTime    =. (now <$ guard rated)
+            | errs <- validateRating sheetType Rating'
-                          , SubmissionRatingPoints  =. ratingPoints'
+                        { ratingPoints  = ratingPoints'
-                          , SubmissionRatingComment =. ratingComment'
+                        , 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
+                when (rated && isNothing submissionRatingTime) $ do
-                $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
+                  $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
-                queueDBJob . JobQueueNotification $ NotificationSubmissionRated 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 ()

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
-instance Universe HelpIdentOptions where universe = universeDef
 instance Finite HelpIdentOptions
 
-instance PathPiece HelpIdentOptions where
+nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
-  toPathPiece   = $(nullaryToPathPiece ''HelpIdentOptions [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
-  fromPathPiece = finiteFromPathPiece
-
-instance RenderMessage UniWorX HelpIdentOptions where
-  renderMessage foundation ls = renderMessage foundation ls . \case 
-    HIUser      -> MsgHelpUser 
-    HIEmail     -> MsgHelpEMail
-    HIAnonymous -> MsgHelpAnonymous
 
 data HelpForm = HelpForm
   { hfReferer:: Maybe (Route UniWorX)

src/Handler/Sheet.hs

@@ -246,11 +246,7 @@ data ButtonGeneratePseudonym = BtnGenerate
 instance Universe ButtonGeneratePseudonym
 instance Finite ButtonGeneratePseudonym
 
-$(return [])
+nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
-
-instance PathPiece ButtonGeneratePseudonym where
-  toPathPiece = $(nullaryToPathPiece ''ButtonGeneratePseudonym [Text.unwords . drop 1 . splitCamel])
-  fromPathPiece = finiteFromPathPiece
 
 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)

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
+nullaryPathPiece ''ActionSystemMessage (camelToPathPiece' 1)
-  renderMessage m ls = renderMessage m ls . \case
+embedRenderMessage ''UniWorX ''ActionSystemMessage (("SystemMessage" <>) . dropPrefix "SM")
-    SMDelete -> MsgSystemMessageDelete
-    SMActivate -> MsgSystemMessageActivate
-    SMDeactivate -> MsgSystemMessageDeactivate
 
 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

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 [])
+nullaryPathPiece ''BtnSubmitDelete (camelToPathPiece' 1 . dropSuffix "'")
-
-instance PathPiece BtnSubmitDelete where
-  toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ])
-  fromPathPiece = finiteFromPathPiece
 
 
 -- -- 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
+uploadModeField = selectField optionsFinite
-  [ (MsgUploadModeNone    , NoUpload      )
-  , (MsgUploadModeNoUnpack, Upload   False)
-  , (MsgUploadModeUnpack  , Upload   True )
-  ]
 
 submissionModeField :: Field Handler SheetSubmissionMode
-submissionModeField = selectFieldList
+submissionModeField = selectField optionsFinite
-  [ (MsgSheetNoSubmission, NoSubmissions)
-  , (MsgSheetCorrectorSubmissions, CorrectorSubmissions)
-  , (MsgSheetUserSubmissions, UserSubmissions)
-  ]
 
 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 [])
+nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
-
-instance PathPiece SheetGrading' where
-  toPathPiece = $(nullaryToPathPiece ''SheetGrading' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
-  fromPathPiece = finiteFromPathPiece
-
 embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)  
 
 
@@ -335,12 +316,7 @@ data SheetType' = Bonus' | Normal' | Informational' | NotGraded'
 instance Universe SheetType'
 instance Finite SheetType'
 
-$(return [])
+nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
-
-instance PathPiece SheetType' where
-  toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
-  fromPathPiece = finiteFromPathPiece
-
 embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)  
 
 
@@ -350,19 +326,8 @@ data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
 instance Universe SheetGroup'
 instance Finite SheetGroup'
 
-$(return [])
+nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
-
+embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
-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
 
 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

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
+nullaryPathPiece ''Theme (camelToPathPiece' 1)
-  toPathPiece   = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
-  fromPathPiece = finiteFromPathPiece
 
 $(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
+nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
-  toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map toLower . unsafeTail . splitCamel])
-  fromPathPiece = finiteFromPathPiece
 
 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
+nullaryPathPiece ''AuthTag (camelToPathPiece' 1)
-  toPathPiece = $(nullaryToPathPiece ''AuthTag [Text.intercalate "-" . map toLower . drop 1 . splitCamel])
-  fromPathPiece = finiteFromPathPiece
 
 instance ToJSONKey AuthTag where
   toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t

src/Settings/Cluster.hs

@@ -42,15 +42,11 @@ data ClusterSettingsKey
 instance Universe ClusterSettingsKey
 instance Finite ClusterSettingsKey
 
-$(return [])
+nullaryPathPiece ''ClusterSettingsKey (camelToPathPiece' 1)
-
-instance PathPiece ClusterSettingsKey where
-  toPathPiece = $(nullaryToPathPiece ''ClusterSettingsKey [intercalate "-" . map toLower . drop 1 . splitCamel])
-  fromPathPiece = finiteFromPathPiece
 
 deriveJSON
   defaultOptions
-    { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    { constructorTagModifier = camelToPathPiece' 1
     }
   ''ClusterSettingsKey
 

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

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
+nullaryPathPiece ''MessageClass camelToPathPiece
-  toPathPiece   = $(nullaryToPathPiece ''MessageClass [toLower])
-  fromPathPiece = finiteFromPathPiece
-
 derivePersistField "MessageClass"
 
 

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 :: Name -> (Text -> Text) -> ExpQ
-nullaryToPathPiece nullaryType manglers = do
+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

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');

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

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>_{MsgSheetSubmissionMode}
-      <dt .deflist__dt>_{MsgSheetPseudonym}
+    <dd .deflist__dd>_{sheetSubmissionMode sheet}
-      <dd .deflist__dd #pseudonym>
+      $case sheetSubmissionMode sheet
-        $maybe pseudonym <- mPseudonym
+        $of CorrectorSubmissions
-          <span .pseudonym>#{pseudonym}
+          <div .js-tooltip>
-        $nothing
+            <div .tooltip__handle>
-          <form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}>
+            <div .tooltip__content>_{MsgSheetCorrectorSubmissionsTip}
-            ^{generateWidget}
+        $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>

templates/standalone/modal.lucius

@@ -1,4 +1,4 @@
-.modal {
+div.modal {
   position: fixed;
   left: 50%;
   top: 50%;