persistent-template 0.5.1 → 0.6.1
raw patch · 5 files changed
+553/−632 lines, 5 filesdep −web-routes-quasidep ~persistentsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: web-routes-quasi
Dependency ranges changed: persistent
API changes (from Hackage documentation)
- Database.Persist.TH: instance Lift PersistOrder
- Database.Persist.TH: instance SinglePiece PersistValue
+ Database.Persist.TH: MkPersistSettings :: Type -> MkPersistSettings
+ Database.Persist.TH: data MkPersistSettings
+ Database.Persist.TH: instance Lift ColumnDef
+ Database.Persist.TH: instance Lift UniqueDef
+ Database.Persist.TH: mpsBackend :: MkPersistSettings -> Type
+ Database.Persist.TH: sqlSettings :: MkPersistSettings
- Database.Persist.TH: mkPersist :: [EntityDef] -> Q [Dec]
+ Database.Persist.TH: mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
Files
- Database/Persist/TH.hs +495/−604
- LICENSE +25/−0
- Setup.hs +0/−2
- Setup.lhs +7/−0
- persistent-template.cabal +26/−26
Database/Persist/TH.hs view
@@ -1,604 +1,495 @@-{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} --- | This module provides utilities for creating backends. Regular users do not --- need to use this module. -module Database.Persist.TH - ( mkPersist - , share - , persist - , persistFile - , share2 - , mkSave - , mkDeleteCascade - , derivePersistField - , mkMigrate - ) where - -import Database.Persist.Base -import Database.Persist.GenericSql (Migration, SqlPersist, migrate) -import Database.Persist.Quasi (parse) -import Database.Persist.Util (deprecate, nullable) -import Database.Persist.TH.Library (apE) -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Data.Char (toLower, toUpper) -import Data.Maybe (mapMaybe, catMaybes) -import Web.Routes.Quasi (SinglePiece (..)) -import Control.Monad (forM) -import Control.Monad.IO.Control (MonadControlIO) -import qualified System.IO as SIO -import Data.Text (pack) -import qualified Data.Text.Read -import qualified Data.Text as T - --- | Converts a quasi-quoted syntax into a list of entity definitions, to be --- used as input to the template haskell generation code (mkPersist). -persist :: QuasiQuoter -persist = QuasiQuoter - { quoteExp = lift . parse - } - -persistFile :: FilePath -> Q Exp -persistFile fp = do - h <- qRunIO $ SIO.openFile fp SIO.ReadMode - qRunIO $ SIO.hSetEncoding h SIO.utf8_bom - s <- qRunIO $ SIO.hGetContents h - lift $ parse s - --- | Create data types and appropriate 'PersistEntity' instances for the given --- 'EntityDef's. Works well with the persist quasi-quoter. -mkPersist :: [EntityDef] -> Q [Dec] -mkPersist = fmap concat . mapM mkEntity - -recName :: String -> String -> String -recName dt f = lowerFirst dt ++ upperFirst f - -lowerFirst :: String -> String -lowerFirst (x:xs) = toLower x : xs -lowerFirst [] = [] - -upperFirst :: String -> String -upperFirst (x:xs) = toUpper x : xs -upperFirst [] = [] - -dataTypeDec :: EntityDef -> Dec -dataTypeDec t = - let name = mkName $ entityName t - cols = map (mkCol $ entityName t) $ entityColumns t - in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t - where - mkCol x (n, ty, as) = - (mkName $ recName x n, NotStrict, pairToType (ty, nullable as)) - -keyTypeDec :: String -> Name -> EntityDef -> Dec -keyTypeDec constr typ t = - NewtypeInstD [] ''Key [ConT $ mkName $ entityName t] - (RecC (mkName constr) [(mkName $ "un" ++ entityName t ++ "Id", NotStrict, ConT typ)]) - [''Show, ''Read, ''Eq, ''PersistField, ''SinglePiece, ''Ord] - -filterTypeDec :: EntityDef -> Dec -filterTypeDec t = - DataInstD [] ''Filter [ConT $ mkName $ entityName t] - (NormalC (mkName $ entityName t ++ "IdIn") [(NotStrict, listOfIds)] - : map (mkFilter $ entityName t) filts) - (if null filts then [] else [''Show, ''Read, ''Eq]) - where - listOfIds = ListT `AppT` (ConT ''Key `AppT` ConT (mkName $ entityName t)) - filts = entityFilters t - -entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)] -entityFilters = mapMaybe go' . concatMap go . entityColumns - where - go (x, y, as) = map (\a -> (x, y, nullable as, a)) as - go' (x, y, z, a) = - case readMay a of - Nothing -> Nothing - Just a' -> Just (x, y, z, a') - -readMay :: Read a => String -> Maybe a -readMay s = - case reads s of - (x, _):_ -> Just x - [] -> Nothing - -isFilterList :: PersistFilter -> Bool -isFilterList In = True -isFilterList NotIn = True -isFilterList _ = False - -mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con -mkFilter x (s, ty, isNull', filt) = - NormalC (mkName $ x ++ upperFirst s ++ show filt) [(NotStrict, ty'')] - where - ty' = pairToType (ty, isNull' && isNullableFilter filt) - ty'' = if isFilterList filt then ListT `AppT` ty' else ty' - isNullableFilter Eq = True - isNullableFilter Ne = True - isNullableFilter In = True - isNullableFilter NotIn = True - isNullableFilter Lt = False - isNullableFilter Le = False - isNullableFilter Gt = False - isNullableFilter Ge = False - -updateTypeDec :: EntityDef -> Dec -updateTypeDec t = - DataInstD [] ''Update [ConT $ mkName $ entityName t] - (map (mkUpdate $ entityName t) tu) - (if null tu then [] else [''Show, ''Read, ''Eq]) - where - tu = entityUpdates t - -entityUpdates :: EntityDef -> [(String, String, Bool, PersistUpdate)] -entityUpdates = mapMaybe go' . concatMap go . entityColumns - where - go (x, y, as) = map (\a -> (x, y, nullable as, a)) as - go' (x, y, z, "update") = - deprecate "'update' is deprecated; please use 'Update'" - $ Just (x, y, z, Update) - go' (x, y, z, a) = - case readMay a of - Nothing -> Nothing - Just a' -> Just (x, y, z, a') - -mkUpdate :: String -> (String, String, Bool, PersistUpdate) -> Con -mkUpdate x (s, ty, isBool, pu) = - NormalC (mkName $ updateConName x s pu) [(NotStrict, pairToType (ty, isBool))] - -orderTypeDec :: EntityDef -> Q Dec -orderTypeDec t = do - ords <- entityOrders t - return $ DataInstD [] ''Order [ConT $ mkName $ entityName t] - (map (mkOrder $ entityName t) ords) - (if null ords then [] else [''Show, ''Read, ''Eq]) - -entityOrders :: EntityDef -> Q [(String, String, Exp)] -entityOrders = fmap concat . mapM go . entityColumns - where - go (x, _, ys) = fmap catMaybes $ mapM (go' x) ys - go' x s = - case reads s of - (y, _):_ -> do - z <- lift (y :: PersistOrder) - return $ Just (x, s, z) - _ -> return Nothing - -mkOrder :: String -> (String, String, Exp) -> Con -mkOrder x (s, ad, _) = NormalC (mkName $ x ++ upperFirst s ++ ad) [] - -uniqueTypeDec :: EntityDef -> Dec -uniqueTypeDec t = - DataInstD [] ''Unique [ConT $ mkName $ entityName t] - (map (mkUnique t) $ entityUniques t) - (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq]) - -mkUnique :: EntityDef -> (String, [String]) -> Con -mkUnique t (constr, fields) = - NormalC (mkName constr) types - where - types = map (go . flip lookup3 (entityColumns t)) fields - go (_, True) = error "Error: cannot have nullables in unique" - go x = (NotStrict, pairToType x) - lookup3 s [] = - error $ "Column not found: " ++ s ++ " in unique " ++ constr - lookup3 x ((x', y, z):rest) - | x == x' = (y, nullable z) - | otherwise = lookup3 x rest - -pairToType :: (String, Bool) -> Type -pairToType (s, False) = ConT $ mkName s -pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s) - -degen :: [Clause] -> [Clause] -degen [] = - let err = VarE (mkName "error") `AppE` LitE (StringL - "Degenerate case, should never happen") - in [Clause [WildP] (NormalB err) []] -degen x = x - -mkToPersistFields :: [(String, Int)] -> Q Dec -mkToPersistFields pairs = do - clauses <- mapM go pairs - return $ FunD (mkName "toPersistFields") $ degen clauses - where - go :: (String, Int) -> Q Clause - go (constr, fields) = do - xs <- sequence $ replicate fields $ newName "x" - let pat = ConP (mkName constr) $ map VarP xs - sp <- [|SomePersistField|] - let bod = ListE $ map (AppE sp . VarE) xs - return $ Clause [pat] (NormalB bod) [] - -mkToFieldNames :: [(String, [String])] -> Dec -mkToFieldNames pairs = - FunD (mkName "persistUniqueToFieldNames") $ degen $ map go pairs - where - go (constr, names) = - Clause [RecP (mkName constr) []] - (NormalB $ ListE $ map (LitE . StringL) names) - [] - -mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec -mkToUpdate name pairs = do - pairs' <- mapM go pairs - return $ FunD (mkName name) $ degen pairs' - where - go (constr, pu) = do - pu' <- lift pu - return $ Clause [RecP (mkName constr) []] (NormalB pu') [] - -mkUniqueToValues :: [(String, [String])] -> Q Dec -mkUniqueToValues pairs = do - pairs' <- mapM go pairs - return $ FunD (mkName "persistUniqueToValues") $ degen pairs' - where - go :: (String, [String]) -> Q Clause - go (constr, names) = do - xs <- mapM (const $ newName "x") names - let pat = ConP (mkName constr) $ map VarP xs - tpv <- [|toPersistValue|] - let bod = ListE $ map (AppE tpv . VarE) xs - return $ Clause [pat] (NormalB bod) [] - -mkToFieldName :: String -> [(String, String)] -> Dec -mkToFieldName func pairs = - FunD (mkName func) $ degen $ map go pairs - where - go (constr, name) = - Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) [] - -mkToOrder :: [(String, Exp)] -> Dec -mkToOrder pairs = - FunD (mkName "persistOrderToOrder") $ degen $ map go pairs - where - go (constr, val) = - Clause [RecP (mkName constr) []] (NormalB val) [] - -mkToFilter :: EntityDef -> [(String, PersistFilter, Bool)] -> Q [Dec] -mkToFilter e pairs = do - c1 <- mapM go pairs - idIn' <- idIn - let _FIXMEc2 = concatMap go' pairs - return - [ FunD (mkName "persistFilterToFilter") $ idIn' : c1 - ] - where - idIn = do - in_ <- [|In|] - return $ Clause - [RecP (mkName $ entityName e ++ "IdIn") []] - (NormalB in_) - [] - go (constr, pf, _) = do - pf' <- lift pf - return $ Clause [RecP (mkName constr) []] (NormalB pf') [] - go' (constr, _, False) = - [Clause [RecP (mkName constr) []] - (NormalB $ ConE $ mkName "False") []] - go' (constr, _, True) = - [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]] - (NormalB $ ConE $ mkName "True") [] - , Clause [ConP (mkName constr) [WildP]] - (NormalB $ ConE $ mkName "False") [] - ] - -mkToValue :: String -> [String] -> Dec -mkToValue func = FunD (mkName func) . degen . map go - where - go constr = - let x = mkName "x" - in Clause [ConP (mkName constr) [VarP x]] - (NormalB $ VarE (mkName "toPersistValue") `AppE` VarE x) - [] - -mkToFiltValue :: EntityDef -> String -> [(String, Bool)] -> Q Dec -mkToFiltValue e func pairs = do - left <- [|Left . toPersistValue|] - right <- [|Right . map toPersistValue|] - clauses <- mapM (go left right) pairs - inId' <- inId right - return $ FunD (mkName func) $ (inId' : clauses) - where - inId right = do - x <- newName "x" - return $ Clause - [ConP (mkName $ entityName e ++ "IdIn") [VarP x]] - (NormalB $ right `AppE` VarE x) - [] - go left right (constr, isList) = do - x <- newName "x" - return - $ Clause [ConP (mkName constr) [VarP x]] - (NormalB $ (if isList then right else left) `AppE` VarE x) - [] - -mkHalfDefined :: String -> Int -> Dec -mkHalfDefined constr count' = - FunD (mkName "halfDefined") - [Clause [] (NormalB - $ foldl AppE (ConE $ mkName constr) - (replicate count' $ VarE $ mkName "undefined")) []] - -mkFromPersistValues :: EntityDef -> Q [Clause] -mkFromPersistValues t = do - nothing <- [|Left "Invalid fromPersistValues input"|] - let cons = ConE $ mkName $ entityName t - xs <- mapM (const $ newName "x") $ entityColumns t - fs <- [|fromPersistValue|] - let xs' = map (AppE fs . VarE) xs - let pat = ListP $ map VarP xs - ap' <- [|apE|] - just <- [|Right|] - let cons' = just `AppE` cons - return - [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') [] - , Clause [WildP] (NormalB nothing) [] - ] - where - go ap' x y = InfixE (Just x) ap' (Just y) - -mkEntity :: EntityDef -> Q [Dec] -mkEntity t = do - t' <- lift t - let name = entityName t - let clazz = ConT ''PersistEntity `AppT` ConT (mkName $ entityName t) - tpf <- mkToPersistFields [(name, length $ entityColumns t)] - fpv <- mkFromPersistValues t - utv <- mkUniqueToValues $ entityUniques t - entityOrders' <- entityOrders t - otd <- orderTypeDec t - puk <- mkUniqueKeys t - tf <- mkToFilter t - (map (\(x, _, z, y) -> - (name ++ upperFirst x ++ show y, y, z)) - $ entityFilters t) - ftv <- mkToFiltValue t "persistFilterToValue" - $ map (\(x, _, _, y) -> - (name ++ upperFirst x ++ show y, isFilterList y)) - $ entityFilters t - putu <- mkToUpdate "persistUpdateToUpdate" - $ map (\(s, _, _, pu) -> (updateConName name s pu, pu)) - $ entityUpdates t - return - [ dataTypeDec t - , TySynD (mkName $ entityName t ++ "Id") [] $ - ConT ''Key `AppT` ConT (mkName $ entityName t) - , InstanceD [] clazz $ - [ keyTypeDec (entityName t ++ "Id") ''PersistValue t - , filterTypeDec t - , updateTypeDec t - , otd - , uniqueTypeDec t - , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []] - , tpf - , FunD (mkName "fromPersistValues") fpv - , mkHalfDefined name $ length $ entityColumns t - , FunD (mkName "toPersistKey") [Clause [] (NormalB $ ConE $ mkName $ entityName t ++ "Id") []] - , FunD (mkName "fromPersistKey") [Clause [] (NormalB $ VarE $ mkName $ "un" ++ entityName t ++ "Id") []] - , mkToFieldName "persistOrderToFieldName" - $ map (\(x, y, _) -> (name ++ upperFirst x ++ y, x)) - entityOrders' - , mkToOrder - $ map (\(x, y, z) -> (name ++ upperFirst x ++ y, z)) - entityOrders' - , mkToFieldName "persistUpdateToFieldName" - $ map (\(s, _, _, pu) -> (updateConName name s pu, s)) - $ entityUpdates t - , mkToValue "persistUpdateToValue" - $ map (\(s, _, _, pu) -> updateConName name s pu) - $ entityUpdates t - , putu - , mkToFieldName "persistFilterToFieldName" - $ (:) (entityName t ++ "IdIn", "id") - $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x)) - $ entityFilters t - , ftv - , mkToFieldNames $ entityUniques t - , utv - , puk - ] ++ tf - ] - -updateConName :: String -> String -> PersistUpdate -> String -updateConName name s pu = concat - [ name - , upperFirst s - , case pu of - Update -> "" - _ -> show pu - ] - -share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec] -share fs x = fmap concat $ mapM ($ x) fs - -share2 :: ([EntityDef] -> Q [Dec]) - -> ([EntityDef] -> Q [Dec]) - -> [EntityDef] - -> Q [Dec] -share2 f g x = do - y <- f x - z <- g x - return $ y ++ z - -mkSave :: String -> [EntityDef] -> Q [Dec] -mkSave name' defs' = do - let name = mkName name' - defs <- lift defs' - return [ SigD name $ ListT `AppT` ConT ''EntityDef - , FunD name [Clause [] (NormalB defs) []] - ] - -data Dep = Dep - { depTarget :: String - , depSourceTable :: String - , depSourceField :: String - , depSourceNull :: Bool - } - -mkDeleteCascade :: [EntityDef] -> Q [Dec] -mkDeleteCascade defs = do - let deps = concatMap getDeps defs - mapM (go deps) defs - where - getDeps :: EntityDef -> [Dep] - getDeps def = - concatMap getDeps' $ entityColumns def - where - getDeps' (name, typ, attribs) = - let isNull = nullable attribs - l = length typ - (f, b) = splitAt (l - 2) typ - in if b == "Id" - then return Dep - { depTarget = f - , depSourceTable = entityName def - , depSourceField = name - , depSourceNull = isNull - } - else [] - go :: [Dep] -> EntityDef -> Q Dec - go allDeps EntityDef{entityName = name} = do - let deps = filter (\x -> depTarget x == name) allDeps - key <- newName "key" - del <- [|delete|] - dcw <- [|deleteCascadeWhere|] - just <- [|Just|] - let mkStmt dep = NoBindS - $ dcw `AppE` - ListE - [ ConE (mkName filtName) `AppE` val (depSourceNull dep) - ] - where - filtName = - depSourceTable dep ++ upperFirst (depSourceField dep) - ++ "Eq" - val False = VarE key - val True = just `AppE` VarE key - - - - let stmts = map mkStmt deps ++ [NoBindS $ del `AppE` VarE key] - return $ - InstanceD - [] - (ConT ''DeleteCascade `AppT` ConT (mkName name)) - [ FunD (mkName "deleteCascade") - [Clause [VarP key] (NormalB $ DoE stmts) []] - ] - -mkUniqueKeys :: EntityDef -> Q Dec -mkUniqueKeys def = do - c <- clause - return $ FunD (mkName "persistUniqueKeys") [c] - where - clause = do - xs <- forM (entityColumns def) $ \(x, _, _) -> do - x' <- newName $ '_' : x - return (x, x') - let pcs = map (go xs) $ entityUniques def - let pat = ConP (mkName $ entityName def) $ map (VarP . snd) xs - return $ Clause [pat] (NormalB $ ListE pcs) [] - go xs (name, cols) = - foldl (go' xs) (ConE (mkName name)) cols - go' xs front col = - let Just col' = lookup col xs - in front `AppE` VarE col' - --- | Automatically creates a valid 'PersistField' instance for any datatype --- that has valid 'Show' and 'Read' instances. Can be very convenient for --- 'Enum' types. -derivePersistField :: String -> Q [Dec] -derivePersistField s = do - ss <- [|SqlString|] - tpv <- [|PersistText . pack . show|] - fpv <- [|\dt v -> - case fromPersistValue v of - Left e -> Left e - Right s' -> - case reads s' of - (x, _):_ -> Right x - [] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|] - return - [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName s)) - [ FunD (mkName "sqlType") - [ Clause [WildP] (NormalB ss) [] - ] - , FunD (mkName "toPersistValue") - [ Clause [] (NormalB tpv) [] - ] - , FunD (mkName "fromPersistValue") - [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) [] - ] - ] - ] - --- | Creates a single function to perform all migrations for the entities --- defined here. One thing to be aware of is dependencies: if you have entities --- with foreign references, make sure to place those definitions after the --- entities they reference. -mkMigrate :: String -> [EntityDef] -> Q [Dec] -mkMigrate fun defs = do - body' <- body - return - [ SigD (mkName fun) typ - , FunD (mkName fun) [Clause [] (NormalB body') []] - ] - where - typ = ForallT [PlainTV $ mkName "m"] - [ ClassP ''MonadControlIO [VarT $ mkName "m"] - ] - $ ConT ''Migration `AppT` (ConT ''SqlPersist `AppT` VarT (mkName "m")) - body :: Q Exp - body = - case defs of - [] -> [|return ()|] - _ -> DoE `fmap` mapM toStmt defs - toStmt :: EntityDef -> Q Stmt - toStmt ed = do - let n = entityName ed - u <- [|undefined|] - m <- [|migrate|] - let u' = SigE u $ ConT $ mkName n - return $ NoBindS $ m `AppE` u' - -instance Lift EntityDef where - lift (EntityDef a b c d e) = do - x <- [|EntityDef|] - a' <- lift a - b' <- lift b - c' <- lift c - d' <- lift d - e' <- lift e - return $ x `AppE` a' `AppE` b' `AppE` c' `AppE` d' `AppE` e' - -instance Lift PersistFilter where - lift Eq = [|Eq|] - lift Ne = [|Ne|] - lift Gt = [|Gt|] - lift Lt = [|Lt|] - lift Ge = [|Ge|] - lift Le = [|Le|] - lift In = [|In|] - lift NotIn = [|NotIn|] - -instance Lift PersistOrder where - lift Asc = [|Asc|] - lift Desc = [|Desc|] - -instance Lift PersistUpdate where - lift Update = [|Update|] - lift Add = [|Add|] - lift Subtract = [|Subtract|] - lift Multiply = [|Multiply|] - lift Divide = [|Divide|] - -instance SinglePiece PersistValue where - fromSinglePiece t = - case Data.Text.Read.signed Data.Text.Read.decimal t of - Right (i, t') - | T.null t' -> Just $ PersistInt64 i - _ -> Just $ PersistText t - toSinglePiece x = - case fromPersistValue x of - Left e -> error e - Right y -> y +{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}+-- | This module provides utilities for creating backends. Regular users do not+-- need to use this module.+module Database.Persist.TH+ ( mkPersist+ , share+ , persist+ , persistFile+ , share2+ , mkSave+ , mkDeleteCascade+ , derivePersistField+ , mkMigrate+ , MkPersistSettings (..)+ , sqlSettings+ ) where++import Database.Persist.Base+import Database.Persist.GenericSql (Migration, SqlPersist, migrate)+import Database.Persist.Quasi (parse)+import Database.Persist.Util (nullable)+import Database.Persist.TH.Library (apE)+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Data.Char (toLower, toUpper)+import Control.Monad (forM)+import Control.Monad.IO.Control (MonadControlIO)+import qualified System.IO as SIO+import Data.Text (pack)+import Data.List (isSuffixOf)++-- | Converts a quasi-quoted syntax into a list of entity definitions, to be+-- used as input to the template haskell generation code (mkPersist).+persist :: QuasiQuoter+persist = QuasiQuoter+ { quoteExp = lift . parse+ }++persistFile :: FilePath -> Q Exp+persistFile fp = do+ h <- qRunIO $ SIO.openFile fp SIO.ReadMode+ qRunIO $ SIO.hSetEncoding h SIO.utf8_bom+ s <- qRunIO $ SIO.hGetContents h+ lift $ parse s++-- | Create data types and appropriate 'PersistEntity' instances for the given+-- 'EntityDef's. Works well with the persist quasi-quoter.+mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]+mkPersist mps = fmap concat . mapM (mkEntity mps)++data MkPersistSettings = MkPersistSettings+ { mpsBackend :: Type+ }++sqlSettings :: MkPersistSettings+sqlSettings = MkPersistSettings+ { mpsBackend = ConT ''SqlPersist+ }++recName :: String -> String -> String+recName dt f = lowerFirst dt ++ upperFirst f++lowerFirst :: String -> String+lowerFirst (x:xs) = toLower x : xs+lowerFirst [] = []++upperFirst :: String -> String+upperFirst (x:xs) = toUpper x : xs+upperFirst [] = []++dataTypeDec :: EntityDef -> Dec+dataTypeDec t =+ DataD [] nameG [PlainTV backend] [RecC name cols] $ map mkName $ entityDerives t+ where+ mkCol x (ColumnDef n ty as) =+ (mkName $ recName x n, NotStrict, pairToType backend (ty, nullable as))+ nameG = mkName $ entityName t ++ suffix+ name = mkName $ entityName t+ cols = map (mkCol $ entityName t) $ entityColumns t+ backend = mkName "backend"++readMay :: Read a => String -> Maybe a+readMay s =+ case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++entityUpdates :: EntityDef -> [(String, String, Bool, PersistUpdate)]+entityUpdates =+ concatMap go . entityColumns+ where+ go (ColumnDef x y as) = map (\a -> (x, y, nullable as, a)) [minBound..maxBound]++uniqueTypeDec :: EntityDef -> Dec+uniqueTypeDec t =+ DataInstD [] ''Unique [ConT (mkName (entityName t ++ suffix)) `AppT` VarT backend, VarT backend2]+ (map (mkUnique backend t) $ entityUniques t)+ (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq])+ where+ backend = mkName "backend"+ backend2 = mkName "backend2"++mkUnique :: Name -> EntityDef -> UniqueDef -> Con+mkUnique backend t (UniqueDef constr fields) =+ NormalC (mkName constr) types+ where+ types = map (go . flip lookup3 (entityColumns t)) fields+ go (_, True) = error "Error: cannot have nullables in unique"+ go x = (NotStrict, pairToType backend x)+ lookup3 s [] =+ error $ "Column not found: " ++ s ++ " in unique " ++ constr+ lookup3 x ((ColumnDef x' y z):rest)+ | x == x' = (y, nullable z)+ | otherwise = lookup3 x rest++pairToType :: Name -- ^ backend+ -> (String, Bool) -> Type+pairToType backend (s, False) = idType backend s+pairToType backend (s, True) = ConT (mkName "Maybe") `AppT` idType backend s++idType :: Name -> String -> Type+idType backend typ+ | "Id" `isSuffixOf` typ = ConT ''Key `AppT` VarT backend `AppT` ConT (mkName $ take (length typ - 2) typ)+ | otherwise = ConT $ mkName typ++degen :: [Clause] -> [Clause]+degen [] =+ let err = VarE (mkName "error") `AppE` LitE (StringL+ "Degenerate case, should never happen")+ in [Clause [WildP] (NormalB err) []]+degen x = x++mkToPersistFields :: [(String, Int)] -> Q Dec+mkToPersistFields pairs = do+ clauses <- mapM go pairs+ return $ FunD (mkName "toPersistFields") $ degen clauses+ where+ go :: (String, Int) -> Q Clause+ go (constr, fields) = do+ xs <- sequence $ replicate fields $ newName "x"+ let pat = ConP (mkName constr) $ map VarP xs+ sp <- [|SomePersistField|]+ let bod = ListE $ map (AppE sp . VarE) xs+ return $ Clause [pat] (NormalB bod) []++mkToFieldNames :: [UniqueDef] -> Dec+mkToFieldNames pairs =+ FunD (mkName "persistUniqueToFieldNames") $ degen $ map go pairs+ where+ go (UniqueDef constr names) =+ Clause [RecP (mkName constr) []]+ (NormalB $ ListE $ map (LitE . StringL) names)+ []++mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec+mkToUpdate name pairs = do+ pairs' <- mapM go pairs+ return $ FunD (mkName name) $ degen pairs'+ where+ go (constr, pu) = do+ pu' <- lift pu+ return $ Clause [RecP (mkName constr) []] (NormalB pu') []++mkUniqueToValues :: [UniqueDef] -> Q Dec+mkUniqueToValues pairs = do+ pairs' <- mapM go pairs+ return $ FunD (mkName "persistUniqueToValues") $ degen pairs'+ where+ go :: UniqueDef -> Q Clause+ go (UniqueDef constr names) = do+ xs <- mapM (const $ newName "x") names+ let pat = ConP (mkName constr) $ map VarP xs+ tpv <- [|toPersistValue|]+ let bod = ListE $ map (AppE tpv . VarE) xs+ return $ Clause [pat] (NormalB bod) []++mkToFieldName :: String -> [(String, String)] -> Dec+mkToFieldName func pairs =+ FunD (mkName func) $ degen $ map go pairs+ where+ go (constr, name) =+ Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) []++mkToOrder :: [(String, Exp)] -> Dec+mkToOrder pairs =+ FunD (mkName "persistOrderToOrder") $ degen $ map go pairs+ where+ go (constr, val) =+ Clause [RecP (mkName constr) []] (NormalB val) []++mkToValue :: String -> [String] -> Dec+mkToValue func = FunD (mkName func) . degen . map go+ where+ go constr =+ let x = mkName "x"+ in Clause [ConP (mkName constr) [VarP x]]+ (NormalB $ VarE (mkName "toPersistValue") `AppE` VarE x)+ []++mkHalfDefined :: String -> Int -> Dec+mkHalfDefined constr count' =+ FunD (mkName "halfDefined")+ [Clause [] (NormalB+ $ foldl AppE (ConE $ mkName constr)+ (replicate count' $ VarE $ mkName "undefined")) []]++mkFromPersistValues :: EntityDef -> Q [Clause]+mkFromPersistValues t = do+ nothing <- [|Left "Invalid fromPersistValues input"|]+ let cons = ConE $ mkName $ entityName t+ xs <- mapM (const $ newName "x") $ entityColumns t+ fs <- [|fromPersistValue|]+ let xs' = map (AppE fs . VarE) xs+ let pat = ListP $ map VarP xs+ ap' <- [|apE|]+ just <- [|Right|]+ let cons' = just `AppE` cons+ return+ [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') []+ , Clause [WildP] (NormalB nothing) []+ ]+ where+ go ap' x y = InfixE (Just x) ap' (Just y)++mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec]+mkEntity mps t = do+ t' <- lift t+ let name = entityName t+ let clazz = ConT ''PersistEntity `AppT` (ConT (mkName $ entityName t ++ suffix) `AppT` VarT (mkName "backend"))+ tpf <- mkToPersistFields [(name, length $ entityColumns t)]+ fpv <- mkFromPersistValues t+ utv <- mkUniqueToValues $ entityUniques t+ puk <- mkUniqueKeys t+ fields <- mapM (mkField t) $ ColumnDef "id" (entityName t ++ "Id") [] : entityColumns t+ return $+ [ dataTypeDec t+ , TySynD (mkName $ entityName t) [] $+ ConT (mkName $ entityName t ++ suffix) `AppT` mpsBackend mps+ , TySynD (mkName $ entityName t ++ "Id") [] $+ ConT ''Key `AppT` mpsBackend mps `AppT` ConT (mkName $ entityName t)+ , InstanceD [] clazz $+ [ uniqueTypeDec t+ , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []]+ , tpf+ , FunD (mkName "fromPersistValues") fpv+ , mkHalfDefined name $ length $ entityColumns t+ , mkToFieldNames $ entityUniques t+ , utv+ , puk+ , DataInstD+ []+ ''EntityField+ [ ConT (mkName $ entityName t ++ suffix) `AppT` VarT (mkName "backend")+ , VarT $ mkName "typ"+ ]+ (map fst fields)+ []+ , FunD (mkName "persistColumnDef") (map snd fields)+ ]+ ]++updateConName :: String -> String -> PersistUpdate -> String+updateConName name s pu = concat+ [ name+ , upperFirst s+ , case pu of+ Assign -> ""+ _ -> show pu+ ]++share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]+share fs x = fmap concat $ mapM ($ x) fs++share2 :: ([EntityDef] -> Q [Dec])+ -> ([EntityDef] -> Q [Dec])+ -> [EntityDef]+ -> Q [Dec]+share2 f g x = do+ y <- f x+ z <- g x+ return $ y ++ z++mkSave :: String -> [EntityDef] -> Q [Dec]+mkSave name' defs' = do+ let name = mkName name'+ defs <- lift defs'+ return [ SigD name $ ListT `AppT` ConT ''EntityDef+ , FunD name [Clause [] (NormalB defs) []]+ ]++data Dep = Dep+ { depTarget :: String+ , depSourceTable :: String+ , depSourceField :: String+ , depSourceNull :: Bool+ }++mkDeleteCascade :: [EntityDef] -> Q [Dec]+mkDeleteCascade defs = do+ let deps = concatMap getDeps defs+ mapM (go deps) defs+ where+ getDeps :: EntityDef -> [Dep]+ getDeps def =+ concatMap getDeps' $ entityColumns def+ where+ getDeps' (ColumnDef name typ attribs) =+ let isNull = nullable attribs+ l = length typ+ (f, b) = splitAt (l - 2) typ+ in if b == "Id"+ then return Dep+ { depTarget = f+ , depSourceTable = entityName def+ , depSourceField = name+ , depSourceNull = isNull+ }+ else []+ go :: [Dep] -> EntityDef -> Q Dec+ go allDeps EntityDef{entityName = name} = do+ let deps = filter (\x -> depTarget x == name) allDeps+ key <- newName "key"+ del <- [|delete|]+ dcw <- [|deleteCascadeWhere|]+ just <- [|Just|]+ filt <- [|Filter|]+ eq <- [|Eq|]+ left <- [|Left|]+ let mkStmt dep = NoBindS+ $ dcw `AppE`+ ListE+ [ filt `AppE` ConE (mkName filtName)+ `AppE` (left `AppE` val (depSourceNull dep))+ `AppE` eq+ ]+ where+ filtName = depSourceTable dep ++ upperFirst (depSourceField dep)+ val False = VarE key+ val True = just `AppE` VarE key++++ let stmts = map mkStmt deps ++ [NoBindS $ del `AppE` VarE key]+ return $+ InstanceD+ []+ (ConT ''DeleteCascade `AppT`+ (ConT (mkName $ name ++ suffix) `AppT` VarT (mkName "backend"))+ `AppT` VarT (mkName "backend")+ )+ [ FunD (mkName "deleteCascade")+ [Clause [VarP key] (NormalB $ DoE stmts) []]+ ]++mkUniqueKeys :: EntityDef -> Q Dec+mkUniqueKeys def = do+ c <- clause+ return $ FunD (mkName "persistUniqueKeys") [c]+ where+ clause = do+ xs <- forM (entityColumns def) $ \(ColumnDef x _ _) -> do+ x' <- newName $ '_' : x+ return (x, x')+ let pcs = map (go xs) $ entityUniques def+ let pat = ConP (mkName $ entityName def) $ map (VarP . snd) xs+ return $ Clause [pat] (NormalB $ ListE pcs) []+ go xs (UniqueDef name cols) =+ foldl (go' xs) (ConE (mkName name)) cols+ go' xs front col =+ let Just col' = lookup col xs+ in front `AppE` VarE col'++-- | Automatically creates a valid 'PersistField' instance for any datatype+-- that has valid 'Show' and 'Read' instances. Can be very convenient for+-- 'Enum' types.+derivePersistField :: String -> Q [Dec]+derivePersistField s = do+ ss <- [|SqlString|]+ tpv <- [|PersistText . pack . show|]+ fpv <- [|\dt v ->+ case fromPersistValue v of+ Left e -> Left e+ Right s' ->+ case reads s' of+ (x, _):_ -> Right x+ [] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|]+ return+ [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName s))+ [ FunD (mkName "sqlType")+ [ Clause [WildP] (NormalB ss) []+ ]+ , FunD (mkName "toPersistValue")+ [ Clause [] (NormalB tpv) []+ ]+ , FunD (mkName "fromPersistValue")+ [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) []+ ]+ ]+ ]++-- | Creates a single function to perform all migrations for the entities+-- defined here. One thing to be aware of is dependencies: if you have entities+-- with foreign references, make sure to place those definitions after the+-- entities they reference.+mkMigrate :: String -> [EntityDef] -> Q [Dec]+mkMigrate fun defs = do+ body' <- body+ return+ [ SigD (mkName fun) typ+ , FunD (mkName fun) [Clause [] (NormalB body') []]+ ]+ where+ typ = ForallT [PlainTV $ mkName "m"]+ [ ClassP ''MonadControlIO [VarT $ mkName "m"]+ ]+ $ ConT ''Migration `AppT` (ConT ''SqlPersist `AppT` VarT (mkName "m"))+ body :: Q Exp+ body =+ case defs of+ [] -> [|return ()|]+ _ -> DoE `fmap` mapM toStmt defs+ toStmt :: EntityDef -> Q Stmt+ toStmt ed = do+ let n = entityName ed+ u <- [|undefined|]+ m <- [|migrate|]+ let u' = SigE u $ ConT $ mkName n+ return $ NoBindS $ m `AppE` u'++instance Lift EntityDef where+ lift (EntityDef a b c d e) = do+ x <- [|EntityDef|]+ a' <- lift a+ b' <- lift b+ c' <- lift c+ d' <- lift d+ e' <- lift e+ return $ x `AppE` a' `AppE` b' `AppE` c' `AppE` d' `AppE` e'+instance Lift ColumnDef where+ lift (ColumnDef a b c) = [|ColumnDef $(lift a) $(lift b) $(lift c)|]+instance Lift UniqueDef where+ lift (UniqueDef a b) = [|UniqueDef $(lift a) $(lift b)|]++instance Lift PersistFilter where+ lift Eq = [|Eq|]+ lift Ne = [|Ne|]+ lift Gt = [|Gt|]+ lift Lt = [|Lt|]+ lift Ge = [|Ge|]+ lift Le = [|Le|]+ lift In = [|In|]+ lift NotIn = [|NotIn|]+ lift (BackendSpecificFilter x) = [|BackendSpecificFilter $(lift x)|]++instance Lift PersistUpdate where+ lift Assign = [|Assign|]+ lift Add = [|Add|]+ lift Subtract = [|Subtract|]+ lift Multiply = [|Multiply|]+ lift Divide = [|Divide|]++mkField :: EntityDef -> ColumnDef -> Q (Con, Clause)+mkField et cd = do+ let con = ForallC+ []+ [EqualP (VarT $ mkName "typ") typ]+ $ NormalC name []+ bod <- lift cd+ let cla = Clause+ [ConP name []]+ (NormalB bod)+ []+ return (con, cla)+ {-+ bod <- [|Field $(lift cd)|]+ return+ [ SigD name $ ConT ''Field `AppT` ConT (mkName $ entityName et) `AppT` typ+ , FunD name [Clause [] (NormalB bod) []]+ ]+ -}+ where+ name = mkName $ concat [entityName et, upperFirst $ columnName cd]+ base =+ if "Id" `isSuffixOf` columnType cd+ then ConT ''Key+ `AppT` (VarT $ mkName "backend")+ `AppT` (ConT (mkName $ take (length (columnType cd) - 2) (columnType cd) ++ suffix) `AppT` VarT (mkName "backend"))+ else ConT (mkName $ columnType cd)+ typ = if nullable $ columnAttribs cd+ then ConT ''Maybe `AppT` base+ else base++suffix :: String+suffix = "Generic"
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
persistent-template.cabal view
@@ -1,26 +1,26 @@-name: persistent-template -version: 0.5.1 -license: BSD3 -author: Michael Snoyman <michael@snoyman.com> -maintainer: Michael Snoyman <michael@snoyman.com> -synopsis: Type-safe, non-relational, multi-backend persistence. -description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful. -category: Database, Yesod -stability: Stable -cabal-version: >= 1.6 -build-type: Simple -homepage: http://www.yesodweb.com/ - -library - build-depends: base >= 4 && < 5 - , template-haskell - , persistent >= 0.5.1 && < 0.6 - , web-routes-quasi >= 0.7 && < 0.8 - , monad-control >= 0.2 && < 0.3 - , text >= 0.5 && < 1.0 - exposed-modules: Database.Persist.TH - ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/snoyberg/persistent.git +name: persistent-template+version: 0.6.1+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Type-safe, non-relational, multi-backend persistence.+description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful.+category: Database, Yesod+stability: Stable+cabal-version: >= 1.6+build-type: Simple+homepage: http://www.yesodweb.com/book/persistent++library+ build-depends: base >= 4 && < 5+ , template-haskell+ , persistent >= 0.6.0 && < 0.7+ , monad-control >= 0.2 && < 0.3+ , text >= 0.5 && < 1.0+ exposed-modules: Database.Persist.TH+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/yesodweb/persistent.git