persistent-template 0.6.3.1 → 0.7.0

raw patch · 2 files changed

+292/−125 lines, 2 filesdep +containersdep ~persistentPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: persistent

API changes (from Hackage documentation)

Files

• Database/Persist/TH.hs +289/−123
• persistent-template.cabal +3/−2

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

@@ -1,5 +1,5 @@ name:            persistent-template-version:         0.6.3.1+version:         0.7.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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