persistent-template 1.0.0.2 → 2.12.0.0
raw patch · 5 files changed
Files
- ChangeLog.md +176/−0
- Database/Persist/TH.hs +0/−843
- README.md +29/−0
- persistent-template.cabal +9/−30
- test/main.hs +0/−50
+ ChangeLog.md view
@@ -0,0 +1,176 @@+## Unreleased changes++## 2.12.0.0++* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)+* [#1214](https://github.com/yesodweb/persistent/pull/1214):+ * This package was asborbed into `persistent` itself.++## 2.9.1.0++* [#1145](https://github.com/yesodweb/persistent/pull/1148)+ * Fix a bug where the `SqlType` for a shared primary key was being+ incorrectly set to `SqlString` instead of whatever the target primary key+ sql type was.+* [#1151](https://github.com/yesodweb/persistent/pull/1151)+ * Automatically generate `SymbolToField` instances for datatypes, allowing+ `OverloadedLabels` to be used with the `EntityField` type.++## 2.9++* Always use the "stock" strategy when deriving Show/Read for keys [#1106](https://github.com/yesodweb/persistent/pull/1106)+ * This fixes a regression from 2.8.0, which started using the `newtype` strategy when deriving `Show`/`Read` for keys+ * In practice, this means that from 2.8.0–2.8.3.1, for the following schema:++ ```+ Person+ name Text+ CustomPrimary+ anInt Int+ Primary anInt+ name Text+ ```++ `PersonKey 1` would show as `"SqlBackendKey {unSqlBackendKey = 1}"`+ and `CustomPrimaryKey 1` would show as `"1"`++ This was generally poor for debugging and logging, since all tables keys would print the same. For Persistent < 2.8.0 and > 2.8.3.1, they instead will show as:++ `"PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}"`+ and `"CustomPrimaryKey {unCustomPrimaryKey = 1}"`++ This could be a breaking change if you have used `Show` on a key, wrote that string into some persistent storage like a database, and are trying to `Read` it back again later.++## 2.8.3.1++* Allow aeson 1.5. [#1085](https://github.com/yesodweb/persistent/pull/1085)++## 2.8.3.0++* Add `Lift` instances for the cascade types. [#1060](https://github.com/yesodweb/persistent/pull/1060)+* Use `DeriveLift` to implement all `Lift` instances. Among other benefits,+ this provides implementations of `liftTyped` on `template-haskell-2.16` (GHC+ 8.10) or later. [#1064](https://github.com/yesodweb/persistent/pull/1064)++## 2.8.2.3++* Require extensions in a more friendly manner. [#1030](https://github.com/yesodweb/persistent/pull/1030)+* Specify a strategy for all deriving clauses, which avoids the `-Wmissing-deriving-strategy` warning introduced in GHC 8.8.2. [#1030](https://github.com/yesodweb/persistent/pull/1030)++## 2.8.2.2++* Fix the `mkPersist` function to not require importing the classes explicitly. [#1027](https://github.com/yesodweb/persistent/pull/1027)++## 2.8.2.1++* Fix the test-suite for persistent-template. [#1023](https://github.com/yesodweb/persistent/pull/1023)++## 2.8.2++* Add `fieldError` to the export list of `Database.Persist.TH` [#1008](https://github.com/yesodweb/persistent/pull/1008)++## 2.8.1++* Let the user pass instances that will be derived for record and for key types (https://github.com/yesodweb/persistent/pull/990++## 2.8.0.1++* Small optimization/code cleanup to generated Template Haskell code size, by slimming the implementation of to/fromPersistValue for Entities. [#1014](https://github.com/yesodweb/persistent/pull/1014)++## 2.8.0++* Reduces the amount of code generated by Template Haskell. The amount of code generated for a certain function was O(N^2) with respect to the number of fields on a given Entity. This change shows dramatic improvements in benchmarks for compiling Persistent models. [#]()+* Drops support for GHC 8.0, so that `DerivingStrategies` can be used by `persistent-template`+* `persistent-template` now requires `DerivingStrategies`, `GeneralizedNewtypeDeriving`, and `StandaloneDeriving` to be enabled in the file where Persistent entities are created+* Fixes a long-standing issue where persistent-template would fail when `DeriveAnyClass` was enabled (See #578)+* [#1002](https://github.com/yesodweb/persistent/pull/1002)++## 2.7.4++* Remove an overlapping instance for `Lift a`. [#998](https://github.com/yesodweb/persistent/pull/998)++## 2.7.3++* Update module documentation for `Database.Persist.TH` to better describe the purpose of the module [#968](https://github.com/yesodweb/persistent/pull/968)+* Support template-haskell-2.15 [#959](https://github.com/yesodweb/persistent/pull/959)++## 2.7.2++* Expose the knot tying logic of `parseReferences` so that users can build+ migrations from independently define entities at runtime [#932](https://github.com/yesodweb/persistent/pull/932)++## 2.7.1++* Add the `mkEntityDefList` function to work around [#902](https://github.com/yesodweb/persistent/issues/902). [#904](https://github.com/yesodweb/persistent/pull/904)++## 2.7.0++* Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and `AtLeastOneUniqueKey` classes. Automatically generates instances for these classes based on how many unique keys the entity definition gets. This changes requires `UndecidableInstances` to be enabled on each module that generates entity definitions. [#885](https://github.com/yesodweb/persistent/pull/885)+* Removed deprecated `sqlOnlySettings`. Please use `sqlSettings` instead. [#894](https://github.com/yesodweb/persistent/pull/894)++## 2.6.0+* [persistent#846](https://github.com/yesodweb/persistent/pull/846): Improve error message when marshalling fails+* [persistent#826](https://github.com/yesodweb/persistent/pull/826): Change `Unique` derive `Show`++## 2.5.4++* [persistent#778](https://github.com/yesodweb/persistent/issues/778): Add `persistManyFileWith`.++## 2.5.3.1++* Slight improvement to the error message when a Persistent field can't be parsed from database results++## 2.5.3++* Exposed `parseReferences` to allow custom QuasiQuoters++## 2.5.2++* Fix incorrect `ToJSON`/`FromJSON` instance generation for generic+ backends++## 2.5.1.6++Allow non-null self-references in a list++## 2.5.1.4++* Allow composite Primary keys for tables that contain nullable fields.+* Support foreign keys to non-integer ids++## 2.5.1.3++* fix GHC 7.8 bug when a field name is "type"++## 2.5.1.2++* fix a bad Eq instance /= definition for Key when mpsGenetric=True++## 2.5.0.1++* workaround TH bug in GHC 7.10++## 2.5++* read/write typeclass split++## 2.1.6++* aeson 0.11+* transformers 0.5+## 2.1.4++support http-api-data for url serialization++## 2.1.3.3++By default explicitly use Int64 for foreign key references.+This avoids confusion on a 32 bit system.++## 2.1.3.1++Support foreign key references to composite primary keys++## 2.1.0.1++Support for monad-control 1.0
− Database/Persist/TH.hs
@@ -1,843 +0,0 @@-{-# 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- ( -- * Parse entity defs- persistWith- , persistUpperCase- , persistLowerCase- , persistFileWith- -- ** Deprecated synonyms- , persist- , persistFile- -- * Turn @EntityDef@s into types- , mkPersist- , MkPersistSettings (..)- , sqlSettings- -- * Various other TH functions- , mkMigrate- , mkSave- , mkDeleteCascade- , share- , derivePersistField- , persistFieldFromEntity- -- ** Deprecated- , share2- ) where--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.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, (<=<), mzero)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.IO.Class (MonadIO)-import qualified System.IO as SIO-import Data.Text (pack, Text, append, unpack, concat, uncons, cons)-import qualified Data.Text.IO as TIO-import Data.List (foldl')-import Data.Monoid (mappend, mconcat)-import qualified Data.Map as M-import Data.Aeson- ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object- , Value (Object), (.:), (.:?)- )-import Control.Applicative (pure, (<*>))---- | Converts a quasi-quoted syntax into a list of entity definitions, to be--- used as input to the template haskell generation code (mkPersist).-persistWith :: PersistSettings -> QuasiQuoter-persistWith ps = QuasiQuoter- { quoteExp = lift . parse ps . pack- }---- | 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-#ifdef GHC_7_4- qAddDependentFile fp-#endif- h <- qRunIO $ SIO.openFile fp SIO.ReadMode- qRunIO $ SIO.hSetEncoding h SIO.utf8_bom- 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 ents = do- x <- fmap mconcat $ mapM persistFieldFromEntity ents- y <- fmap mconcat $ mapM (mkEntity mps) ents- z <- fmap mconcat $ mapM mkJSON ents- return $ mconcat [x, y, z]---- | 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 :: Text -> Text -> Text-recName dt f = lowerFirst dt ++ upperFirst f--lowerFirst :: Text -> Text-lowerFirst t =- case uncons t of- Just (a, b) -> cons (toLower a) b- Nothing -> t--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 [KindedTV backend monadTransKind] constrs- $ map (mkName . unpack) $ entityDerives t- where-#if MIN_VERSION_template_haskell(2,8,0)- arrowK x y = ArrowT `AppT` x `AppT` y- monadKind = StarT `arrowK` StarT- monadTransKind = monadKind `arrowK` monadKind-#else- monadKind = StarK `ArrowK` StarK- monadTransKind = monadKind `ArrowK` monadKind-#endif- mkCol x (FieldDef n _ ty as) =- (mkName $ unpack $ recName x $ unHaskellName n,- NotStrict,- pairToType backend (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"-- constrs- | entitySum t = map sumCon $ entityFields t- | otherwise = [RecC name cols]-- sumCon fd@(FieldDef _ _ ty _) = NormalC- (sumConstrName t fd)- [(NotStrict, pairToType backend (ty, False))]--sumConstrName :: EntityDef -> FieldDef -> Name-sumConstrName t (FieldDef n _ _ _) = mkName $ unpack $ concat- [ unHaskellName $ entityHaskell t- , upperFirst $ unHaskellName n- , "Sum"- ]--readMay :: Read a => String -> Maybe a-readMay s =- case reads s of- (x, _):_ -> Just x- [] -> Nothing--entityUpdates :: EntityDef -> [(HaskellName, FieldType, Bool, PersistUpdate)]-entityUpdates =- concatMap go . entityFields- where- go (FieldDef x _ y as) = map (\a -> (x, y, nullable as, a)) [minBound..maxBound]--uniqueTypeDec :: EntityDef -> Dec-uniqueTypeDec t =- DataInstD [] ''Unique- [ ConT (mkName $ unpack (unHaskellName (entityHaskell t) ++ suffix))- `AppT` VarT backend, VarT backend2- ]- (map (mkUnique backend t) $ entityUniques t)- []- where- backend = mkName "backend"- backend2 = mkName "backend2"--mkUnique :: Name -> EntityDef -> UniqueDef -> Con-mkUnique backend t (UniqueDef (HaskellName constr) _ fields) =- NormalC (mkName $ unpack constr) types- where- 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 (ft, y) = (NotStrict, pairToType backend (ft, y))-- lookup3 :: Text -> [FieldDef] -> (FieldType, Bool)- lookup3 s [] =- 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- -> (FieldType, Bool) -- ^ True == has Maybe attr- -> Type-pairToType backend (s, False) = idType backend s-pairToType backend (s, True) = ConT (mkName "Maybe") `AppT` idType backend s--idType :: Name -> FieldType -> Type-idType backend typ =- case stripId typ of- Just typ' ->- ConT ''Key- `AppT` VarT backend- `AppT` (ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` VarT backend)- Nothing -> ftToType 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 -> EntityDef -> Q Dec-mkToPersistFields constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do- clauses <-- if isSum- then sequence $ zipWith goSum fields [1..]- else fmap return go- return $ FunD (mkName "toPersistFields") clauses- where- go :: Q Clause- go = do- xs <- sequence $ replicate fieldCount $ 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) []-- fieldCount = length fields-- goSum :: FieldDef -> Int -> Q Clause- goSum fd idx = do- let name = sumConstrName ed fd- enull <- [|SomePersistField PersistNull|]- let beforeCount = idx - 1- afterCount = fieldCount - idx- before = replicate beforeCount enull- after = replicate afterCount enull- x <- newName "x"- sp <- [|SomePersistField|]- let body = NormalB $ ListE $ mconcat- [ before- , [sp `AppE` VarE x]- , after- ]- return $ Clause [ConP name [VarP x]] body []---mkToFieldNames :: [UniqueDef] -> Q Dec-mkToFieldNames pairs = do- pairs' <- mapM go pairs- return $ FunD (mkName "persistUniqueToFieldNames") $ degen pairs'- where- 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- 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 $ unpack $ unHaskellName 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 :: Name -> Int -> Dec-mkHalfDefined constr count' =- FunD (mkName "halfDefined")- [Clause [] (NormalB- $ foldl AppE (ConE constr)- (replicate count' $ VarE $ mkName "undefined")) []]--mkFromPersistValues :: EntityDef -> Q [Clause]-mkFromPersistValues t@(EntityDef { entitySum = False }) = do- 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'- return- [ Clause [pat] (NormalB $ foldl (go ap') cons'' xs') []- , Clause [WildP] (NormalB nothing) []- ]- where- go ap' x y = InfixE (Just x) ap' (Just y)-mkFromPersistValues t@(EntityDef { entitySum = True }) = do- nothing <- [|Left $(liftT "Invalid fromPersistValues input")|]- clauses <- mkClauses [] $ entityFields t- return $ clauses `mappend` [Clause [WildP] (NormalB nothing) []]- where- mkClauses _ [] = return []- mkClauses before (field:after) = do- x <- newName "x"- let null' = ConP 'PersistNull []- pat = ListP $ mconcat- [ map (const null') before- , [VarP x]- , map (const null') after- ]- constr = ConE $ sumConstrName t field- fmap' <- [|fmap|]- fs <- [|fromPersistValue $(return $ VarE x)|]- let clause = Clause [pat] (NormalB $ InfixE (Just constr) fmap' (Just fs)) []- clauses <- mkClauses (field : before) after- return $ clause : clauses--mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec]-mkEntity mps t = do- t' <- lift t- let nameT = unHaskellName $ entityHaskell t- let nameS = unpack nameT- let clazz = ConT ''PersistEntity `AppT` (ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) `AppT` VarT (mkName "backend"))- tpf <- mkToPersistFields nameS t- fpv <- mkFromPersistValues t- utv <- mkUniqueToValues $ entityUniques t- puk <- mkUniqueKeys t-- fields <- mapM (mkField t) $ FieldDef- (HaskellName "Id")- (entityID t)- (FTTypeCon Nothing $ unHaskellName (entityHaskell t) ++ "Id")- []- : entityFields t- toFieldNames <- mkToFieldNames $ entityUniques t-- return- [ dataTypeDec t- , TySynD (mkName nameS) [] $- ConT (mkName $ unpack $ nameT ++ suffix)- `AppT` mpsBackend mps- , TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $- ConT ''Key `AppT` mpsBackend mps `AppT` ConT (mkName nameS)- , InstanceD [] clazz $- [ uniqueTypeDec t- , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []]- , tpf- , FunD (mkName "fromPersistValues") fpv- , mkHalfDefined- (if entitySum t- then sumConstrName t (head $ entityFields t)- else mkName nameS)- (if entitySum t then 1 else length $ entityFields t)- , toFieldNames- , utv- , puk- , DataInstD- []- ''EntityField- [ ConT (mkName $ unpack $ nameT ++ suffix) `AppT` VarT (mkName "backend")- , VarT $ mkName "typ"- ]- (map fst 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") []]- ]- ]---- | 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|]- let columnNames = map (unpack . unHaskellName . fieldHaskell) (entityFields e)- obj <- [|\ent -> PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields ent)|]- fpv <- [|\x -> fromPersistValues $ map (\(_,v) -> case fromPersistValue v of- Left e' -> error $ unpack e'- Right r -> r) x|]- let typ = ConT (mkName $ entityName `mappend` "Generic")- `AppT` VarT (mkName "backend")-- compose <- [|(<=<)|]- getPersistMap' <- [|getPersistMap|]- return- [ persistFieldInstanceD typ- [ sqlTypeFunD ss- , FunD (mkName "toPersistValue") [ Clause [] (NormalB obj) [] ]- , FunD (mkName "fromPersistValue")- [ Clause [] (NormalB $ InfixE (Just fpv) compose $ Just getPersistMap') []- ]- ]- ]- where- entityName = (unpack $ unHaskellName $ entityHaskell e)--updateConName :: Text -> Text -> PersistUpdate -> Text-updateConName name s pu = concat- [ name- , upperFirst s- , case pu of- Assign -> ""- _ -> 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 mconcat $ mapM ($ x) fs---- | Deprecated, restricted version of 'share'.-share2 :: ([EntityDef] -> Q [Dec])- -> ([EntityDef] -> Q [Dec])- -> [EntityDef]- -> Q [Dec]-share2 f g x = do- y <- f x- z <- g x- 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'- defs <- lift defs'- return [ SigD name $ ListT `AppT` ConT ''EntityDef- , FunD name [Clause [] (NormalB defs) []]- ]--data Dep = Dep- { 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- mapM (go deps) defs- where- getDeps :: EntityDef -> [Dep]- getDeps def =- concatMap getDeps' $ entityFields def- where- getDeps' :: FieldDef -> [Dep]- getDeps' (FieldDef name _ ftyp attribs) =- let isNull = nullable attribs- in case stripId ftyp of- Just f ->- return Dep- { depTarget = f- , depSourceTable = entityHaskell def- , depSourceField = name- , depSourceNull = isNull- }- Nothing -> []- go :: [Dep] -> EntityDef -> Q Dec- go allDeps EntityDef{entityHaskell = name} = do- let deps = filter (\x -> depTarget x == unHaskellName name) allDeps- key <- newName "key"- del <- [|delete|]- dcw <- [|deleteCascadeWhere|]- just <- [|Just|]- filt <- [|Filter|]- eq <- [|Eq|]- left <- [|Left|]- let mkStmt :: Dep -> Stmt- mkStmt dep = NoBindS- $ dcw `AppE`- ListE- [ filt `AppE` ConE (mkName $ unpack filtName)- `AppE` (left `AppE` val (depSourceNull dep))- `AppE` eq- ]- where- filtName = unHaskellName (depSourceTable dep) ++- upperFirst (unHaskellName $ depSourceField dep)- val False = VarE key- val True = just `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 $ 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) []]- ]--mkUniqueKeys :: EntityDef -> Q Dec-mkUniqueKeys def | entitySum def =- return $ FunD (mkName "persistUniqueKeys") [Clause [WildP] (NormalB $ ListE []) []]-mkUniqueKeys def = do- c <- clause- return $ FunD (mkName "persistUniqueKeys") [c]- where- clause = do- 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 $ unpack $ unHaskellName $ entityHaskell def)- (map (VarP . snd) xs)- return $ Clause [pat] (NormalB $ ListE pcs) []-- 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'--sqlTypeFunD :: Exp -> Dec-sqlTypeFunD st = FunD (mkName "sqlType")- [ Clause [WildP] (NormalB st) [] ]--persistFieldInstanceD :: Type -> [Dec] -> Dec-persistFieldInstanceD typ =- InstanceD [] (ConT ''PersistField `AppT` typ)---- | 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 $ unpack s' of- (x, _):_ -> Right x- [] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|]- return- [ persistFieldInstanceD (ConT $ mkName s)- [ sqlTypeFunD 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 allDefs = do- body' <- body- return- [ SigD (mkName fun) typ- , FunD (mkName fun) [Clause [] (NormalB body') []]- ]- where- defs = filter isMigrated allDefs- isMigrated def = not $ "no-migrate" `elem` entityAttrs def- typ = ForallT [PlainTV $ mkName "m"]- [ ClassP ''MonadBaseControl [ConT ''IO, VarT $ mkName "m"]- , ClassP ''MonadIO [VarT $ mkName "m"]- ]- $ ConT ''Migration `AppT` (ConT ''SqlPersist `AppT` VarT (mkName "m"))- body :: Q Exp- body =- case defs of- [] -> [|return ()|]- _ -> do- defsName <- newName "defs"- defsStmt <- do- u <- [|undefined|]- e <- [|entityDef|]- let defsExp = ListE $ map (AppE e . undefinedEntityTH u) defs- return $ LetS [ValD (VarP defsName) (NormalB defsExp) []]- stmts <- mapM (toStmt $ VarE defsName) defs- return (DoE $ defsStmt : stmts)- toStmt :: Exp -> EntityDef -> Q Stmt- toStmt defsExp ed = do- u <- [|undefined|]- m <- [|migrate|]- return $ NoBindS $ m `AppE` defsExp `AppE` (undefinedEntityTH u ed)- undefinedEntityTH :: Exp -> EntityDef -> Exp- undefinedEntityTH u = SigE u . ConT . mkName . unpack . unHaskellName . entityHaskell--instance Lift EntityDef where- lift (EntityDef a b c d e f g h i) =- [|EntityDef- $(lift a)- $(lift b)- $(lift c)- $(liftTs d)- $(lift e)- $(lift f)- $(liftTs g)- $(liftMap h)- $(lift i)- |]-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 c) = [|UniqueDef $(lift a) $(lift b) $(lift c)|]--pack' :: String -> Text-pack' = pack-#if !MIN_VERSION_text(0, 11, 2)-{-# NOINLINE pack' #-}-#endif--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 :: M.Map Text [[Text]] -> Q Exp-liftMap m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.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 (FTTypeCon Nothing t) = [|FTTypeCon Nothing $(liftT t)|]- lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just $(liftT x)) $(liftT t)|]- lift (FTApp x y) = [|FTApp $(lift x) $(lift y)|]- lift (FTList x) = [|FTList $(lift x)|]--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 $(liftT x)|]--instance Lift PersistUpdate where- lift Assign = [|Assign|]- lift Add = [|Add|]- lift Subtract = [|Subtract|]- lift Multiply = [|Multiply|]- lift Divide = [|Divide|]---- Ent--- fieldName FieldType------ forall . typ ~ FieldType => EntFieldName------ EntFieldName = FieldDef ....-mkField :: EntityDef -> FieldDef -> Q (Con, Clause)-mkField et cd = do- let con = ForallC- []- [EqualP (VarT $ mkName "typ") maybeTyp]- $ NormalC name []- bod <- lift cd- let cla = Clause- [ConP name []]- (NormalB bod)- []- return (con, cla)- where- name = mkName $ unpack $ concat- [ unHaskellName $ entityHaskell et- , upperFirst $ unHaskellName $ fieldHaskell cd- ]- maybeTyp =- if nullable $ fieldAttrs cd- then ConT ''Maybe `AppT` typ- else typ- typ =- case stripId $ fieldType cd of- Just ft ->- ConT ''Key- `AppT` (VarT $ mkName "backend")- `AppT`- let con = ConT $ mkName $ unpack $ ft ++ suffix- in con `AppT` VarT (mkName "backend")- Nothing -> ftToType $ fieldType cd--ftToType :: FieldType -> Type-ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t-ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t]-ftToType (FTApp x y) = ftToType x `AppT` ftToType y-ftToType (FTList x) = ListT `AppT` ftToType x--suffix :: Text-suffix = "Generic"--infixr 5 ++-(++) :: Text -> Text -> Text-(++) = append--mkJSON :: EntityDef -> Q [Dec]-mkJSON def | not ("json" `elem` entityAttrs def) = return []-mkJSON def = do- pureE <- [|pure|]- apE' <- [|(<*>)|]- packE <- [|pack|]- dotEqualE <- [|(.=)|]- dotColonE <- [|(.:)|]- dotColonQE <- [|(.:?)|]- objectE <- [|object|]- obj <- newName "obj"- mzeroE <- [|mzero|]-- xs <- mapM (newName . unpack . unHaskellName . fieldHaskell)- $ entityFields def-- let con = ConT $ mkName $ unpack- (unHaskellName (entityHaskell def) ++ "Generic")- conName = mkName $ unpack $ unHaskellName $ entityHaskell def- typ = con `AppT` VarT (mkName "backend")- toJSONI = InstanceD- []- (ConT ''ToJSON `AppT` typ)- [toJSON']- toJSON' = FunD 'toJSON $ return $ Clause- [ConP conName $ map VarP xs]- (NormalB $ objectE `AppE` ListE pairs)- []- pairs = zipWith toPair (entityFields def) xs- toPair f x = InfixE- (Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f)))- dotEqualE- (Just $ VarE x)- fromJSONI = InstanceD- []- (ConT ''FromJSON `AppT` typ)- [parseJSON']- parseJSON' = FunD 'parseJSON- [ Clause [ConP 'Object [VarP obj]]- (NormalB $ foldl'- (\x y -> InfixE (Just x) apE' (Just y))- (pureE `AppE` ConE conName)- pulls- )- []- , Clause [WildP] (NormalB mzeroE) []- ]- pulls = map toPull $ entityFields def- toPull f = InfixE- (Just $ VarE obj)- (if nullable (fieldAttrs f) then dotColonQE else dotColonE)- (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f)- return [toJSONI, fromJSONI]
+ README.md view
@@ -0,0 +1,29 @@+# Begone!++This package was absorbed into `persistent` with the 2.12.0.1 release.++## persistent-template++Provides Template Haskell helpers for persistent. For more information, see+[the chapter in the Yesod book](http://www.yesodweb.com/book/persistent).++### code organization++The TH.hs module contains code generators.+persistent-template uses `EntityDef`s that it gets from the quasi-quoter.+The quasi-quoter is in persistent Quasi.hs+Similarly many of the types come from the persistent library++### Development tips++To get a better idea of what code you're generating, you can output the content of Template Haskell expressions to a file:++```+stack test persistent-template --ghc-options='-ddump-splices -ddump-to-file'+```++The output will be in the `.stack-work` directory. The exact path will depend on your specific setup, but if you search for files ending in `.dump-splices` you'll find the output (`find .stack-work -type f -name '*.dump-splices'`)++If you make changes to the generated code, it is highly recommended to compare the output with your changes to output from `master` (even better if this diff is included in your PR!). Seemingly small changes can have dramatic changes on the generated code. ++For example, embedding an `EntityDef` in a function that was called for every field of that `Entity` made the number of generated lines O(N^2) for that function—very bad!
persistent-template.cabal view
@@ -1,45 +1,24 @@ name: persistent-template-version: 1.0.0.2+version: 2.12.0.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>-maintainer: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info> 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.+description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/persistent-template>. category: Database, Yesod stability: Stable-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent-extra-source-files: test/main.hs+bug-reports: https://github.com/yesodweb/persistent/issues+extra-source-files: ChangeLog.md README.md library- build-depends: base >= 4 && < 5- , template-haskell- , persistent >= 1.0 && < 1.1- , monad-control >= 0.2 && < 0.4- , text >= 0.5 && < 1.0- , transformers >= 0.2 && < 0.4- , containers- , aeson- exposed-modules: Database.Persist.TH+ build-depends: base >= 4.10 && < 5+ exposed-modules: ghc-options: -Wall- if impl(ghc >= 7.4)- cpp-options: -DGHC_7_4--test-suite test- type: exitcode-stdio-1.0- main-is: main.hs- hs-source-dirs: test-- build-depends: base >= 4 && < 5- , persistent-template- , aeson- , hspec >= 1.3- , text- , persistent- , bytestring- , QuickCheck+ default-language: Haskell2010 source-repository head type: git
− test/main.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-}-{-# LANGUAGE EmptyDataDecls #-}-import Test.Hspec-import Test.Hspec.QuickCheck-import Data.ByteString.Lazy.Char8 ()-import Test.QuickCheck.Arbitrary-import Control.Applicative ((<$>), (<*>))--import Database.Persist-import Database.Persist.TH-import Data.Text (Text, pack)-import Data.Aeson--mkPersist sqlSettings [persistUpperCase|-Person json- name Text- age Int Maybe- address Address- deriving Show Eq-Address json- street Text- city Text- zip Int Maybe- deriving Show Eq-NoJson- foo Text- deriving Show Eq-|]---- ensure no-json works-instance ToJSON (NoJsonGeneric b) where- toJSON = undefined-instance FromJSON (NoJsonGeneric b) where- parseJSON = undefined--arbitraryT = pack <$> arbitrary--instance Arbitrary (PersonGeneric b) where- arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary-instance Arbitrary (AddressGeneric b) where- arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary--main :: IO ()-main = hspec $ do- describe "JSON serialization" $ do- prop "to/from is idempotent" $ \person ->- decode (encode person) == Just (person :: Person)- it "decode" $- decode "{\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just- (Person "Michael" (Just 27) $ Address "Narkis" "Maalot" Nothing)