Show SheetSubmissionMode & cleanup
This commit is contained in:
Gregor Kleen
parent
a3d22baa5b
commit
c26897847c
@ -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.
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 --
|
||||
---------------------
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -19,6 +19,8 @@ $maybe descr <- sheetDescription sheet
|
||||
<dd .deflist__dd>#{solution}
|
||||
<dt .deflist__dt>_{MsgSheetType}
|
||||
<dd .deflist__dd>_{sheetType sheet}
|
||||
<dt .deflist__dt>_{MsgSheetSubmissionMode}
|
||||
<dd .deflist__dd>_{sheetSubmissionMode sheet}
|
||||
$if CorrectorSubmissions == sheetSubmissionMode sheet
|
||||
<dt .deflist__dt>_{MsgSheetPseudonym}
|
||||
<dd .deflist__dd #pseudonym>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user