Minor refactor among utility modules

models

@@ -4,7 +4,8 @@ User
     matrikelnummer Text Maybe
     email          Text
     displayName    Text
-    maxFavourites  Int default=12
+    maxFavourites  Int   default=12
+    theme          Theme default='default'
     UniqueAuthentication plugin ident
     UniqueEmail email
 UserAdmin

src/Foundation.hs

@@ -174,13 +174,13 @@ liftAR :: (MsgRenderer ->  AuthResult -> AuthResult -> AuthResult)
           -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
           -> AccessPredicate -> AccessPredicate -> AccessPredicate
 -- Ensure to first evaluate Pure conditions, then Handler before DB
-liftAR op sc (APPure    f) (APPure     g) = APPure     $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask
+liftAR ops sc (APPure    f) (APPure     g) = APPure     $ \r -> shortCircuitM sc (f r) (g r) . ops =<< ask
-liftAR op sc (APHandler f) (APHandler  g) = APHandler  $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
+liftAR ops sc (APHandler f) (APHandler  g) = APHandler  $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer
-liftAR op sc (APDB      f) (APDB       g) = APDB       $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
+liftAR ops sc (APDB      f) (APDB       g) = APDB       $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer
-liftAR op sc (APPure    f) apg  = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg
+liftAR ops sc (APPure    f) apg  = liftAR ops sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg
-liftAR op sc apf           apg@(APPure _)    = liftAR op sc apg apf
+liftAR ops sc apf           apg@(APPure _)    = liftAR ops sc apg apf
-liftAR op sc (APHandler f) apdb = liftAR op sc (APDB      $ lift . f) apdb
+liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB      $ lift . f) apdb
-liftAR op sc apdb          apg@(APHandler _) = liftAR op sc apg apdb
+liftAR ops sc apdb          apg@(APHandler _) = liftAR ops sc apg apdb
 
 
 trueAP,falseAP :: AccessPredicate
@@ -736,6 +736,7 @@ instance YesodAuth UniWorX where
 
       let
         userMaxFavourites = 12 -- TODO: appDefaultFavourites appSettings
+        userTheme = Default    -- TODO: appDefaultFavourites appSettings
         newUser = User{..}
         userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
                      , UserDisplayName =. userDisplayName

src/Model/Types.hs

@@ -186,7 +186,7 @@ derivePersistField "StudyFieldType"
 
 
 -- Skins / Themes
-data Theme
+data Theme       --Simply add Themes to this type only. CamelCase will be converted to "-lower"
   = Default
   | NeutralBlue
   | AberdeenReds
@@ -194,7 +194,7 @@ data Theme
   | SkyLove
   deriving (Eq,Ord,Bounded,Enum)
 
-$(deriveShowTheme ''Theme)
+$(deriveShowWith uncamel ''Theme)
 
 allThemes :: [Theme]
 allThemes = [minBound..maxBound]
@@ -202,11 +202,11 @@ allThemes = [minBound..maxBound]
 readTheme :: Map String Theme
 readTheme = Map.fromList [ (show t,t) | t <- allThemes ]
 
-instance Read Theme where
+instance Read Theme where -- generic Read-Instance for Show/Bounded
 --   readPrec = undefined
   readsPrec _ s
     | (Just t) <- (Map.lookup s readTheme) = [(t,"")]
-    | otherwise = []
+    | otherwise = [(Default,"")] -- read will always succeed
 
 derivePersistField "Theme"
 

src/Utils.hs

@@ -11,6 +11,9 @@ module Utils
 
 import ClassyPrelude.Yesod
 
+import Data.List (foldl)
+import qualified Data.Char as Char
+
 import Utils.DB as Utils
 import Utils.Common as Utils
 
@@ -64,11 +67,25 @@ withFragment :: ( Monad m
                 ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
 withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
 
+uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "cmael-case-thing"
+uncamel = drop 1 . reverse . foldl helper []
+  where
+    helper _   '.' = []
+    helper acc  c
+      | Char.isSpace c = acc
+      | Char.isUpper c = Char.toLower c : '-' : acc
+      | otherwise = c : acc
 
 ------------
 -- Tuples --
 ------------
 
+fst3 :: (a,b,c) -> a
+fst3 (x,_,_) = x
+snd3 :: (a,b,c) -> b
+snd3 (_,y,_) = y
+trd3 :: (a,b,c) -> c
+trd3 (_,_,z) = z
 ----------
 -- Maps --
 ----------

src/Utils/Common.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 
 module Utils.Common where
--- Common Utility Functions
+-- Common Utility Functions that require TemplateHaskell
 
 import Data.Char
 
@@ -16,12 +16,6 @@ import Language.Haskell.TH
 -- Tuples --
 ------------
 
-fst3 :: (a,b,c) -> a
-fst3 (x,_,_) = x
-snd3 :: (a,b,c) -> b
-snd3 (_,y,_) = y
-trd3 :: (a,b,c) -> c
-trd3 (_,_,z) = z
 
 projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
 -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
@@ -58,15 +52,14 @@ altFun perm = lamE pat rhs
 
 
 -- Special Show-Instances for Themes
-deriveShowTheme :: Name -> Q [Dec]
+deriveShowWith :: (String -> String) -> Name -> Q [Dec]
-deriveShowTheme ty = do
+deriveShowWith 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 ennumeration"
+        _ -> fail "deriveShowTheme: tyCon must be a plain datatype enumeration"
     let instanceT = conT ''Show `appT` conT tyConName
-        decs = return $ genDecs cs
+    return <$> instanceD (return []) instanceT [genDecs cs]
-    sequence [instanceD (return []) instanceT decs]
   where
     genDecs :: [Con] -> Q Dec
     genDecs cs = funD 'show (map genClause cs)
@@ -74,16 +67,7 @@ deriveShowTheme ty = do
     genClause :: Con -> Q Clause
     genClause (NormalC name []) =
       let pats = [ConP name []]
-          body = NormalB $ LitE $ StringL $ uncamel $ show $ name
+          body = NormalB $ LitE $ StringL $ strOp $ show $ name
       in return $ Clause pats body []
     genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"
 
-uncamel :: String -> String
-uncamel = drop 1 . reverse . foldl helper []
-  where
-    helper _   '.' = []
-    helper acc  c
-      | isSpace c = acc
-      | isUpper c = toLower c : '-' : acc
-      | otherwise = c : acc
-