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.GenericSql.Internal (unRawName,rawFieldName,rawTableIdName)
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)
#if MIN_VERSION_monad_control(0, 3, 0)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.IO.Class (MonadIO)
#else
import Control.Monad.IO.Control (MonadControlIO)
#endif
import qualified System.IO as SIO
import Data.Text (pack)
import Data.List (isSuffixOf)
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
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
-> (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
let colnames = map (unRawName . rawFieldName) $ entityColumns t
idname = unRawName $ rawTableIdName t
idname_ = (if idname `elem` colnames then (++"_") else id) idname
fields <- mapM (mkField t) $ ColumnDef idname_ (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'
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)) []
]
]
]
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"]
#if MIN_VERSION_monad_control(0, 3, 0)
[ ClassP ''MonadBaseControl [ConT ''IO, VarT $ mkName "m"]
, ClassP ''MonadIO [VarT $ mkName "m"]
]
#else
[ ClassP ''MonadControlIO [VarT $ mkName "m"]
]
#endif
$ 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)
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"