ThemeDatatype plus TemplateHaskell Show implemented

src/Foundation.hs

@@ -441,7 +441,7 @@ instance Yesod UniWorX where
                    courseRoute = CourseR courseTerm courseShorthand CShowR
                in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
 
-        let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs only
+        let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
             highlight = let crumbs = mcons mcurrentRoute $ fst <$> parents
                             actFav = List.intersect (snd3 <$> favourites) crumbs
                             highRs = if null actFav then crumbs else actFav

src/Model/Types.hs

@@ -183,4 +183,24 @@ data StudyFieldType = FieldPrimary | FieldSecondary
 derivePersistField "StudyFieldType"
 
 
+data Theme
+  = Default
+  | NeutralBlue
+  | AberdeenReds
+  | MintGreen
+  | SkyLove
+  deriving (Eq,Ord,Bounded,Enum)
+$(deriveShowTheme ''Theme)
+
+allThemes :: [Theme]
+allThemes = [minBound..maxBound]
+
+-- instance Show Theme where
+--   show Default = "default"
+--
+
+
+
+-- derivePersistField "Theme"
+
 

src/Utils/Common.hs

@@ -4,6 +4,8 @@
 module Utils.Common where
 -- Common Utility Functions
 
+import Data.Char
+
 import Language.Haskell.TH
 -- import Control.Monad
 -- import Control.Monad.Trans.Class
@@ -54,3 +56,34 @@ altFun perm = lamE pat rhs
         fn  = mkName "fn" 
         
 
+
+-- Special Show-Instances for Themes
+deriveShowTheme :: Name -> Q [Dec]
+deriveShowTheme 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"
+    let instanceT = conT ''Show `appT` conT tyConName
+        decs = return $ genDecs cs
+    sequence [instanceD (return []) instanceT decs]
+  where
+    genDecs :: [Con] -> Q Dec
+    genDecs cs = funD 'show (map genClause cs)
+
+    genClause :: Con -> Q Clause
+    genClause (NormalC name []) =
+      let pats = [ConP name []]
+          body = NormalB $ LitE $ StringL $ uncamel $ 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
+