From f936453204efb574897cb4c5112e09f59e0ac7e4 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 19 Jun 2018 11:05:02 +0200 Subject: [PATCH] Minor refactor among utility modules --- models | 3 ++- src/Foundation.hs | 15 ++++++++------- src/Model/Types.hs | 8 ++++---- src/Utils.hs | 17 +++++++++++++++++ src/Utils/Common.hs | 28 ++++++---------------------- 5 files changed, 37 insertions(+), 34 deletions(-) diff --git a/models b/models index 31f089285..ad99eabd2 100644 --- a/models +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 1eff154d0..01eefae68 100644 --- a/src/Foundation.hs +++ b/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 op sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer -liftAR op sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer -liftAR op sc (APPure f) apg = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg -liftAR op sc apf apg@(APPure _) = liftAR op sc apg apf -liftAR op sc (APHandler f) apdb = liftAR op sc (APDB $ lift . f) apdb -liftAR op sc apdb apg@(APHandler _) = liftAR op sc apg apdb +liftAR ops sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . ops =<< ask +liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer +liftAR ops sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer +liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg +liftAR ops sc apf apg@(APPure _) = liftAR ops sc apg apf +liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ lift . f) 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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index de07f15a7..35b04099f 100644 --- a/src/Model/Types.hs +++ b/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" diff --git a/src/Utils.hs b/src/Utils.hs index 7f6ef4442..faf47afaf 100644 --- a/src/Utils.hs +++ b/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 -- ---------- diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 0821aa276..142a48e90 100644 --- a/src/Utils/Common.hs +++ b/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] -deriveShowTheme ty = do +deriveShowWith :: (String -> String) -> Name -> Q [Dec] +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 - sequence [instanceD (return []) instanceT decs] + return <$> instanceD (return []) instanceT [genDecs cs] 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 -