DisplayAble vs Show for Theme completed.

This commit is contained in:
SJost 2018-06-20 22:58:12 +02:00
parent 8b46a690a8
commit 5cc3920059
4 changed files with 21 additions and 9 deletions

View File

@ -65,10 +65,10 @@ getProfileR = do
[ (MsgName , userDisplayName )
, (MsgIdent , userIdent )
, (MsgPlugin , userPlugin )
, (MsgMatrikelNr , fromMaybe "" userMatrikelnummer)
, (MsgMatrikelNr , display userMatrikelnummer)
, (MsgEMail , userEmail )
, (MsgFavoriten , pack $ show userMaxFavourites)
, (MsgTheme , pack $ show userTheme )
, (MsgFavoriten , display userMaxFavourites)
, (MsgTheme , display userTheme )
]
userDisplay = mconcat
[ headless $ toWgt . mr . fst

View File

@ -197,7 +197,8 @@ data Theme --Simply add Themes to this type only. CamelCase will be conver
| SkyLove
deriving (Eq,Ord,Bounded,Enum)
$(deriveShowWith uncamel ''Theme)
$(deriveShowWith uncamel ''Theme) -- show for internal use in css/js
$(deriveSimpleWith ''DisplayAble 'display camelSpace ''Theme) -- display to display at user
allThemes :: [Theme]
allThemes = [minBound..maxBound]

View File

@ -71,15 +71,23 @@ withFragment :: ( Monad m
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "cmael-case-thing"
uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "camel-case-thing"
uncamel = ("theme-" ++) . reverse . foldl helper []
where
helper _ '.' = []
helper acc c
| Char.isSpace c = acc
| Char.isUpper c = Char.toLower c : '-' : acc
| otherwise = c : acc
| otherwise = c : acc
camelSpace :: String -> String -- "Model.Theme.CamelCaseThing" -> "Camel Case Thing"
camelSpace = reverse . foldl helper []
where
helper _ '.' = []
helper acc c
| Char.isSpace c = acc
| Char.isUpper c = c : ' ' : acc
| otherwise = c : acc
-- Convert anything to Text, and I don't care how
class DisplayAble a where

View File

@ -53,16 +53,19 @@ altFun perm = lamE pat rhs
-- Special Show-Instances for Themes
deriveShowWith :: (String -> String) -> Name -> Q [Dec]
deriveShowWith strOp ty = do
deriveShowWith = deriveSimpleWith ''Show 'show
deriveSimpleWith :: Name -> Name -> (String -> String) -> Name -> Q [Dec]
deriveSimpleWith cls fun strOp ty = do
(TyConI tyCon) <- reify ty
(tyConName, cs) <- case tyCon of
DataD [] nm [] _ cs _ -> return (nm, cs)
_ -> fail "deriveShowTheme: tyCon must be a plain datatype enumeration"
let instanceT = conT ''Show `appT` conT tyConName
let instanceT = conT cls `appT` conT tyConName
return <$> instanceD (return []) instanceT [genDecs cs]
where
genDecs :: [Con] -> Q Dec
genDecs cs = funD 'show (map genClause cs)
genDecs cs = funD fun (map genClause cs)
genClause :: Con -> Q Clause
genClause (NormalC name []) =