diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -1,26 +1,38 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# 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 + ( -- * Parse entity defs + persistWith + , persistUpperCase + , persistLowerCase + , persistFileWith + -- ** Deprecated synonyms , persist , persistFile - , share2 + -- * Turn @EntityDef@s into types + , mkPersist + , MkPersistSettings (..) + , sqlSettings + -- * Various other TH functions + , mkMigrate , mkSave , mkDeleteCascade + , share , derivePersistField - , mkMigrate - , MkPersistSettings (..) - , sqlSettings + -- ** Deprecated + , share2 ) where -import Database.Persist.Base +import Prelude hiding ((++), take, concat, splitAt) +import Database.Persist.EntityDef +import Database.Persist.Quasi +import Database.Persist.Store +import Database.Persist.Query.Internal import Database.Persist.GenericSql (Migration, SqlPersist, migrate) -import Database.Persist.GenericSql.Internal (unRawName,rawFieldName,rawTableIdName) -- XXX -import Database.Persist.Quasi (parse) import Database.Persist.Util (nullable) import Database.Persist.TH.Library (apE) import Language.Haskell.TH.Quote @@ -34,57 +46,95 @@ import Control.Monad.IO.Control (MonadControlIO) #endif import qualified System.IO as SIO -import Data.Text (pack) -import Data.List (isSuffixOf) +import Data.Text (pack, Text, append, isSuffixOf, unpack, take, concat, uncons, cons, splitAt) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.List (foldl') +import Data.Monoid (mappend, mconcat) +import qualified Data.Map as Map -- | 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 +persistWith :: PersistSettings -> QuasiQuoter +persistWith ps = QuasiQuoter + { quoteExp = lift . parse ps . pack } -persistFile :: FilePath -> Q Exp -persistFile fp = do +-- | Deprecate synonym for 'persistUpperCase'. +persist :: QuasiQuoter +persist = persistUpperCase +{-# DEPRECATED persist "Please use persistUpperCase instead." #-} + +-- | Apply 'persistWith' to 'upperCaseSettings'. +persistUpperCase :: QuasiQuoter +persistUpperCase = persistWith upperCaseSettings + +-- | Apply 'persistWith' to 'lowerCaseSettings'. +persistLowerCase :: QuasiQuoter +persistLowerCase = persistWith lowerCaseSettings + +-- | Same as 'persistWith', but uses an external file instead of a +-- quasiquotation. +persistFileWith :: PersistSettings -> FilePath -> Q Exp +persistFileWith ps fp = do h <- qRunIO $ SIO.openFile fp SIO.ReadMode qRunIO $ SIO.hSetEncoding h SIO.utf8_bom - s <- qRunIO $ SIO.hGetContents h - lift $ parse s + s <- qRunIO $ TIO.hGetContents h + lift $ parse ps s +-- | Deprecated function. Equivalent to @persistFileWith upperCaseSettings@. +persistFile :: FilePath -> Q Exp +persistFile = persistFileWith upperCaseSettings + -- | 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) +mkPersist mps = fmap mconcat . mapM (mkEntity mps) +-- | Settings to be passed to the 'mkPersist' function. data MkPersistSettings = MkPersistSettings { mpsBackend :: Type + -- ^ Which database backend we\'re using. + -- + -- When generating data types, each type is given a generic version- which + -- works with any backend- and a type synonym for the commonly used + -- backend. This is where you specify that commonly used backend. } +-- | Use the 'SqlPersist' backend. sqlSettings :: MkPersistSettings sqlSettings = MkPersistSettings { mpsBackend = ConT ''SqlPersist } -recName :: String -> String -> String +recName :: Text -> Text -> Text recName dt f = lowerFirst dt ++ upperFirst f -lowerFirst :: String -> String -lowerFirst (x:xs) = toLower x : xs -lowerFirst [] = [] +lowerFirst :: Text -> Text +lowerFirst t = + case uncons t of + Just (a, b) -> cons (toLower a) b + Nothing -> t -upperFirst :: String -> String -upperFirst (x:xs) = toUpper x : xs -upperFirst [] = [] +upperFirst :: Text -> Text +upperFirst t = + case uncons t of + Just (a, b) -> cons (toUpper a) b + Nothing -> t dataTypeDec :: EntityDef -> Dec dataTypeDec t = - DataD [] nameG [PlainTV backend] [RecC name cols] $ map mkName $ entityDerives t + DataD [] nameG [PlainTV backend] [RecC name cols] + $ map (mkName . unpack) $ 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 + mkCol x (FieldDef n _ ty as) = + (mkName $ unpack $ recName x $ unHaskellName n, + NotStrict, + pairToType backend (unFieldType ty, nullable as) + ) + nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix + name = mkName $ unpack $ unHaskellName $ entityHaskell t + cols = map (mkCol $ unHaskellName $ entityHaskell t) $ entityFields t backend = mkName "backend" readMay :: Read a => String -> Maybe a @@ -93,15 +143,18 @@ (x, _):_ -> Just x [] -> Nothing -entityUpdates :: EntityDef -> [(String, String, Bool, PersistUpdate)] +entityUpdates :: EntityDef -> [(HaskellName, FieldType, Bool, PersistUpdate)] entityUpdates = - concatMap go . entityColumns + concatMap go . entityFields where - go (ColumnDef x y as) = map (\a -> (x, y, nullable as, a)) [minBound..maxBound] + go (FieldDef 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] + DataInstD [] ''Unique + [ ConT (mkName $ unpack (unHaskellName (entityHaskell t) ++ suffix)) + `AppT` VarT backend, VarT backend2 + ] (map (mkUnique backend t) $ entityUniques t) (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq]) where @@ -109,27 +162,36 @@ backend2 = mkName "backend2" mkUnique :: Name -> EntityDef -> UniqueDef -> Con -mkUnique backend t (UniqueDef constr fields) = - NormalC (mkName constr) types +mkUnique backend t (UniqueDef (HaskellName constr) _ fields) = + NormalC (mkName $ unpack constr) types where - types = map (go . flip lookup3 (entityColumns t)) fields + types = map (go . flip lookup3 (entityFields t)) + $ map (unHaskellName . fst) fields + + go :: (FieldType, Bool) -> (Strict, Type) go (_, True) = error "Error: cannot have nullables in unique" - go x = (NotStrict, pairToType backend x) + go (FieldType x, y) = (NotStrict, pairToType backend (x, y)) + + lookup3 :: Text -> [FieldDef] -> (FieldType, Bool) lookup3 s [] = - error $ "Column not found: " ++ s ++ " in unique " ++ constr - lookup3 x ((ColumnDef x' y z):rest) + error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr + lookup3 x ((FieldDef (HaskellName x') _ y z):rest) | x == x' = (y, nullable z) | otherwise = lookup3 x rest pairToType :: Name -- ^ backend - -> (String, Bool) -> Type + -> (Text, 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 :: Name -> Text -> Type idType backend typ - | "Id" `isSuffixOf` typ = ConT ''Key `AppT` VarT backend `AppT` ConT (mkName $ take (length typ - 2) typ) - | otherwise = ConT $ mkName typ + | "Id" `isSuffixOf` typ = + ConT ''Key + `AppT` VarT backend + `AppT` (ConT (mkName $ unpack $ take (T.length typ - 2) typ ++ "Generic") + `AppT` VarT backend) + | otherwise = ConT $ mkName $ unpack typ degen :: [Clause] -> [Clause] degen [] = @@ -151,14 +213,18 @@ 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 +mkToFieldNames :: [UniqueDef] -> Q Dec +mkToFieldNames pairs = do + pairs' <- mapM go pairs + return $ FunD (mkName "persistUniqueToFieldNames") $ degen pairs' where - go (UniqueDef constr names) = - Clause [RecP (mkName constr) []] - (NormalB $ ListE $ map (LitE . StringL) names) - [] + go (UniqueDef constr _ names) = do + names' <- lift names + return $ + Clause + [RecP (mkName $ unpack $ unHaskellName constr) []] + (NormalB names') + [] mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec mkToUpdate name pairs = do @@ -175,9 +241,9 @@ return $ FunD (mkName "persistUniqueToValues") $ degen pairs' where go :: UniqueDef -> Q Clause - go (UniqueDef constr names) = do + go (UniqueDef constr _ names) = do xs <- mapM (const $ newName "x") names - let pat = ConP (mkName constr) $ map VarP xs + let pat = ConP (mkName $ unpack $ unHaskellName constr) $ map VarP xs tpv <- [|toPersistValue|] let bod = ListE $ map (AppE tpv . VarE) xs return $ Clause [pat] (NormalB bod) [] @@ -214,17 +280,17 @@ 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 + nothing <- [|Left $(liftT "Invalid fromPersistValues input")|] + let cons' = ConE $ mkName $ unpack $ unHaskellName $ entityHaskell t + xs <- mapM (const $ newName "x") $ entityFields 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 + let cons'' = just `AppE` cons' return - [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') [] + [ Clause [pat] (NormalB $ foldl (go ap') cons'' xs') [] , Clause [WildP] (NormalB nothing) [] ] where @@ -233,55 +299,100 @@ 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)] + let name = unpack $ unHaskellName $ entityHaskell t + let clazz = ConT ''PersistEntity `AppT` (ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) `AppT` VarT (mkName "backend")) + tpf <- mkToPersistFields [(name, length $ entityFields 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 + fields <- mapM (mkField t) $ FieldDef + (HaskellName "Id") + (entityID t) + (FieldType $ unHaskellName (entityHaskell t) ++ "Id") [] + : entityFields t + toFieldNames <- mkToFieldNames $ entityUniques 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) + , TySynD (mkName $ unpack $ unHaskellName $ entityHaskell t) [] $ + ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) + `AppT` mpsBackend mps + , TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $ + ConT ''Key `AppT` mpsBackend mps `AppT` ConT (mkName $ unpack $ unHaskellName $ entityHaskell 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 + , mkHalfDefined name $ length $ entityFields t + , toFieldNames , utv , puk , DataInstD [] ''EntityField - [ ConT (mkName $ entityName t ++ suffix) `AppT` VarT (mkName "backend") + [ ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) `AppT` VarT (mkName "backend") , VarT $ mkName "typ" ] (map fst fields) [] - , FunD (mkName "persistColumnDef") (map snd fields) + , FunD (mkName "persistFieldDef") (map snd fields) + , TySynInstD + (mkName "PersistEntityBackend") + [ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) `AppT` VarT (mkName "backend")] + (VarT (mkName "backend")) + , FunD (mkName "persistIdField") [Clause [] (NormalB $ ConE $ mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] ] ] -updateConName :: String -> String -> PersistUpdate -> String +-- | produce code similar to the following +-- instance PersistEntity e => PersistField e where +-- toPersistValue = PersistMap $ zip columNames (map toPersistValue . toPersistFields) +-- fromPersistValue (PersistMap o) = fromPersistValues $ map (\(_,v) -> +-- casefromPersistValue v of +-- Left e -> error e +-- Right r -> r) o +-- fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x +-- sqlType _ = SqlString +persistFieldFromEntity :: EntityDef -> Q [Dec] +persistFieldFromEntity e = do + ss <- [|SqlString|] + unexpected <- [|\x -> Left $ "Expected PersistMap, received: " ++ T.pack (show x)|] + let columnNames = map (unpack . unHaskellName . fieldHaskell) (entityFields e) + obj <- [|PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields e)|] + pmName <- newName "pm" + fpv <- [|\x -> fromPersistValues $ map (\(_,v) -> case fromPersistValue v of + Left e' -> error $ unpack e' + Right r -> r) x|] + return + [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName $ unpack $ unHaskellName $ entityHaskell e)) + [ FunD (mkName "sqlType") [ Clause [WildP] (NormalB ss) [] ] + , FunD (mkName "toPersistValue") [ Clause [] (NormalB obj) [] ] + , FunD (mkName "fromPersistValue") + [ Clause [ConP (mkName "PersistMap") [VarP pmName]] + (NormalB $ fpv `AppE` VarE pmName) [] + , Clause [WildP] (NormalB unexpected) [] + ] + ] + ] + +updateConName :: Text -> Text -> PersistUpdate -> Text updateConName name s pu = concat [ name , upperFirst s , case pu of Assign -> "" - _ -> show pu + _ -> pack $ show pu ] +-- | Apply the given list of functions to the same @EntityDef@s. +-- +-- This function is useful for cases such as: +-- +-- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec] -share fs x = fmap concat $ mapM ($ x) fs +share fs x = fmap mconcat $ mapM ($ x) fs +-- | Deprecated, restricted version of 'share'. share2 :: ([EntityDef] -> Q [Dec]) -> ([EntityDef] -> Q [Dec]) -> [EntityDef] @@ -289,8 +400,10 @@ share2 f g x = do y <- f x z <- g x - return $ y ++ z + return $ y `mappend` z +{-# DEPRECATED share2 "Use share instead" #-} +-- | Save the @EntityDef@s passed in under the given name. mkSave :: String -> [EntityDef] -> Q [Dec] mkSave name' defs' = do let name = mkName name' @@ -300,12 +413,13 @@ ] data Dep = Dep - { depTarget :: String - , depSourceTable :: String - , depSourceField :: String + { depTarget :: Text + , depSourceTable :: HaskellName + , depSourceField :: HaskellName , depSourceNull :: Bool } +-- | Generate a 'DeleteCascade' instance for the given @EntityDef@s. mkDeleteCascade :: [EntityDef] -> Q [Dec] mkDeleteCascade defs = do let deps = concatMap getDeps defs @@ -313,23 +427,25 @@ where getDeps :: EntityDef -> [Dep] getDeps def = - concatMap getDeps' $ entityColumns def + concatMap getDeps' $ entityFields def where - getDeps' (ColumnDef name typ attribs) = + getDeps' :: FieldDef -> [Dep] + getDeps' (FieldDef name _ ftyp attribs) = let isNull = nullable attribs - l = length typ + typ = unFieldType ftyp + l = T.length typ (f, b) = splitAt (l - 2) typ in if b == "Id" then return Dep { depTarget = f - , depSourceTable = entityName def + , depSourceTable = entityHaskell 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 + go allDeps EntityDef{entityHaskell = name} = do + let deps = filter (\x -> depTarget x == unHaskellName name) allDeps key <- newName "key" del <- [|delete|] dcw <- [|deleteCascadeWhere|] @@ -337,27 +453,34 @@ filt <- [|Filter|] eq <- [|Eq|] left <- [|Left|] - let mkStmt dep = NoBindS + let mkStmt :: Dep -> Stmt + mkStmt dep = NoBindS $ dcw `AppE` ListE - [ filt `AppE` ConE (mkName filtName) + [ filt `AppE` ConE (mkName $ unpack filtName) `AppE` (left `AppE` val (depSourceNull dep)) `AppE` eq ] where - filtName = depSourceTable dep ++ upperFirst (depSourceField dep) + filtName = unHaskellName (depSourceTable dep) ++ + upperFirst (unHaskellName $ depSourceField dep) val False = VarE key val True = just `AppE` VarE key - let stmts = map mkStmt deps ++ [NoBindS $ del `AppE` VarE key] + let stmts :: [Stmt] + stmts = map mkStmt deps `mappend` + [NoBindS $ del `AppE` VarE key] return $ InstanceD - [] + [ ClassP ''PersistQuery [VarT $ mkName "backend", VarT $ mkName "m"] + , ClassP ''Monad [VarT $ mkName "m"] + ] (ConT ''DeleteCascade `AppT` - (ConT (mkName $ name ++ suffix) `AppT` VarT (mkName "backend")) + (ConT (mkName $ unpack $ unHaskellName name ++ suffix) `AppT` VarT (mkName "backend")) `AppT` VarT (mkName "backend") + `AppT` VarT (mkName "m") ) [ FunD (mkName "deleteCascade") [Clause [VarP key] (NormalB $ DoE stmts) []] @@ -369,14 +492,20 @@ return $ FunD (mkName "persistUniqueKeys") [c] where clause = do - xs <- forM (entityColumns def) $ \(ColumnDef x _ _) -> do - x' <- newName $ '_' : x + xs <- forM (entityFields def) $ \(FieldDef x _ _ _) -> do + x' <- newName $ '_' : unpack (unHaskellName x) return (x, x') let pcs = map (go xs) $ entityUniques def - let pat = ConP (mkName $ entityName def) $ map (VarP . snd) xs + let pat = ConP + (mkName $ unpack $ unHaskellName $ entityHaskell def) + (map (VarP . snd) xs) return $ Clause [pat] (NormalB $ ListE pcs) [] - go xs (UniqueDef name cols) = - foldl (go' xs) (ConE (mkName name)) cols + + go :: [(HaskellName, Name)] -> UniqueDef -> Exp + go xs (UniqueDef name _ cols) = + foldl' (go' xs) (ConE (mkName $ unpack $ unHaskellName name)) (map fst cols) + + go' :: [(HaskellName, Name)] -> Exp -> HaskellName -> Exp go' xs front col = let Just col' = lookup col xs in front `AppE` VarE col' @@ -392,7 +521,7 @@ case fromPersistValue v of Left e -> Left e Right s' -> - case reads s' of + case reads $ unpack s' of (x, _):_ -> Right x [] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|] return @@ -438,26 +567,52 @@ _ -> DoE `fmap` mapM toStmt defs toStmt :: EntityDef -> Q Stmt toStmt ed = do - let n = entityName ed + let n = entityHaskell ed u <- [|undefined|] m <- [|migrate|] - let u' = SigE u $ ConT $ mkName n - return $ NoBindS $ m `AppE` u' + defs' <- lift defs + let u' = SigE u $ ConT $ mkName $ unpack $ unHaskellName n + return $ NoBindS $ m `AppE` defs' `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)|] + lift (EntityDef a b c d e f g h) = + [|EntityDef + $(lift a) + $(lift b) + $(lift c) + $(liftTs d) + $(lift e) + $(lift f) + $(liftTs g) + $(liftMap h) + |] +instance Lift FieldDef where + lift (FieldDef a b c d) = [|FieldDef $(lift a) $(lift b) $(lift c) $(liftTs d)|] instance Lift UniqueDef where - lift (UniqueDef a b) = [|UniqueDef $(lift a) $(lift b)|] + lift (UniqueDef a b c) = [|UniqueDef $(lift a) $(lift b) $(lift c)|] +liftT :: Text -> Q Exp +liftT t = [|pack $(lift (unpack t))|] + +liftTs :: [Text] -> Q Exp +liftTs = fmap ListE . mapM liftT + +liftTss :: [[Text]] -> Q Exp +liftTss = fmap ListE . mapM liftTs + +liftMap :: Map.Map Text [[Text]] -> Q Exp +liftMap m = [|Map.fromList $(fmap ListE $ mapM liftPair $ Map.toList m)|] + +liftPair :: (Text, [[Text]]) -> Q Exp +liftPair (t, ts) = [|($(liftT t), $(liftTss ts))|] + +instance Lift HaskellName where + lift (HaskellName t) = [|HaskellName $(liftT t)|] +instance Lift DBName where + lift (DBName t) = [|DBName $(liftT t)|] +instance Lift FieldType where + lift (FieldType t) = [|FieldType $(liftT t)|] + instance Lift PersistFilter where lift Eq = [|Eq|] lift Ne = [|Ne|] @@ -467,7 +622,7 @@ lift Le = [|Le|] lift In = [|In|] lift NotIn = [|NotIn|] - lift (BackendSpecificFilter x) = [|BackendSpecificFilter $(lift x)|] + lift (BackendSpecificFilter x) = [|BackendSpecificFilter $(liftT x)|] instance Lift PersistUpdate where lift Assign = [|Assign|] @@ -476,7 +631,7 @@ lift Multiply = [|Multiply|] lift Divide = [|Divide|] -mkField :: EntityDef -> ColumnDef -> Q (Con, Clause) +mkField :: EntityDef -> FieldDef -> Q (Con, Clause) mkField et cd = do let con = ForallC [] @@ -491,21 +646,32 @@ {- bod <- [|Field $(lift cd)|] return - [ SigD name $ ConT ''Field `AppT` ConT (mkName $ entityName et) `AppT` typ + [ SigD name $ ConT ''Field `AppT` ConT (mkName $ entityHaskell et) `AppT` typ , FunD name [Clause [] (NormalB bod) []] ] -} where - name = mkName $ concat [entityName et, upperFirst $ columnName cd] + name = mkName $ unpack $ concat + [ unHaskellName $ entityHaskell et + , upperFirst $ unHaskellName $ fieldHaskell cd + ] base = - if "Id" `isSuffixOf` columnType cd + if "Id" `isSuffixOf` unFieldType (fieldType 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 + `AppT` + let len = T.length (unFieldType $ fieldType cd) - 2 + ft = take len $ unFieldType $ fieldType cd + con = ConT $ mkName $ unpack $ ft ++ suffix + in con `AppT` VarT (mkName "backend") + else ConT $ mkName $ unpack $ unFieldType $ fieldType cd + typ = if nullable $ fieldAttrs cd then ConT ''Maybe `AppT` base else base -suffix :: String +suffix :: Text suffix = "Generic" + +infixr 5 ++ +(++) :: Text -> Text -> Text +(++) = append diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -1,5 +1,5 @@ name: persistent-template -version: 0.6.3.1 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -15,10 +15,11 @@ library build-depends: base >= 4 && < 5 , template-haskell - , persistent >= 0.6.2 && < 0.7 + , persistent >= 0.7 && < 0.8 , monad-control >= 0.2 && < 0.4 , text >= 0.5 && < 1.0 , transformers >= 0.2 + , containers exposed-modules: Database.Persist.TH ghc-options: -Wall