fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Minor refactor among utility modules

Browse Source
This commit is contained in:
SJost 2018-06-19 11:05:02 +02:00
parent 171f62ad8a
commit f936453204
5 changed files with 37 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
models
View File

@ -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

15
src/Foundation.hs
View File

@ -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

8
src/Model/Types.hs
View File

@ -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"

17
src/Utils.hs
View File

@ -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 --
----------

28
src/Utils/Common.hs
View File

@ -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