diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 0727e7015..4faefd841 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 0a59d614d..65ab7f57a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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] diff --git a/src/Utils.hs b/src/Utils.hs index 39d79c37b..b06986864 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 97b1e821c..876b68b86 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/Common.hs @@ -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 []) =