From c26897847c9676b667888639701436ff3ec396cb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 19 Nov 2018 13:53:05 +0100 Subject: [PATCH 1/5] Show SheetSubmissionMode & cleanup --- messages/uniworx/de.msg | 4 +-- src/Foundation.hs | 16 +++++++--- src/Handler/Home.hs | 16 ++-------- src/Handler/Sheet.hs | 8 ++--- src/Handler/SystemMessage.hs | 15 +++------ src/Handler/Utils/Form.hs | 61 +++++------------------------------- src/Model/Types.hs | 38 ++++++++++++---------- src/Settings/Cluster.hs | 8 ++--- src/Utils/Form.hs | 19 +++++++++++ src/Utils/Message.hs | 11 ++----- src/Utils/PathPiece.hs | 25 ++++++++++++--- templates/sheetShow.hamlet | 2 ++ 12 files changed, 97 insertions(+), 126 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 9d22120e5..3319c6348 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -338,7 +338,7 @@ UploadModeNone: Kein Upload UploadModeUnpack: Upload, einzelne Datei UploadModeNoUnpack: Upload, ZIP-Archive entpacken -SheetNoSubmission: Keine Abgabe +SheetNoSubmissions: Keine Abgabe SheetCorrectorSubmissions: Abgaben durch Korrektoren SheetUserSubmissions: Direkte Abgabe @@ -431,7 +431,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. diff --git a/src/Foundation.hs b/src/Foundation.hs index eeb86d21c..71893e2b3 100644 --- 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: diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 96e782067..a301af506 100644 --- 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) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index b40e165de..53fd57b47 100644 --- 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) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index b166c5d0d..9ab849b41 100644 --- 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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 079897003..e78d86214 100644 --- 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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b8d18bd8e..75b86551a 100644 --- 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 diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index c072c3bfd..65219f347 100644 --- 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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index f5d950fd4..5450e0f40 100644 --- 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 -- --------------------- diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 62226de75..7c806d996 100644 --- 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" diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index f093ce22f..5e0dd8621 100644 --- 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 diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 9efdc5e24..1f7cd7102 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -19,6 +19,8 @@ $maybe descr <- sheetDescription sheet
#{solution}
_{MsgSheetType}
_{sheetType sheet} +
_{MsgSheetSubmissionMode} +
_{sheetSubmissionMode sheet} $if CorrectorSubmissions == sheetSubmissionMode sheet
_{MsgSheetPseudonym}
From 2747c185b3b0681c62f627c6db680cd26cf50be9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 19 Nov 2018 14:02:00 +0100 Subject: [PATCH 2/5] Reformulate CorrectorSubmissions --- messages/uniworx/de.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 3319c6348..2b25922eb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -339,7 +339,7 @@ UploadModeUnpack: Upload, einzelne Datei UploadModeNoUnpack: Upload, ZIP-Archive entpacken SheetNoSubmissions: Keine Abgabe -SheetCorrectorSubmissions: Abgaben durch Korrektoren +SheetCorrectorSubmissions: Abgabe extern mit Pseudonym SheetUserSubmissions: Direkte Abgabe SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. From 8ea4313b9a92bc931d83f60fc2afe63f1e23f865 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 19 Nov 2018 14:10:55 +0100 Subject: [PATCH 3/5] fix left-margin in modals --- templates/default-layout-wrapper.hamlet | 2 +- templates/default-layout.lucius | 8 ++++---- templates/standalone/modal.lucius | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index 014edc30f..c293b607a 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -12,7 +12,7 @@ $newline never ^{pageHead pc} - +