diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs deleted file mode 100644 --- a/Database/Persist/TH.hs +++ /dev/null @@ -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] diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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! diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -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 -maintainer: Michael Snoyman +maintainer: Michael Snoyman , Greg Weber 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: . 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 diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -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)