diff --git a/src/Foundation.hs b/src/Foundation.hs index 8a9c3a666..1eff154d0 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 3ad4a0868..539cc9bbb 100644 --- a/src/Model/Types.hs +++ b/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" + diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 3a2e6c804..0821aa276 100644 --- a/src/Utils/Common.hs +++ b/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 +