Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-persistent for openSUSE:Factory checked in at 2023-01-18 13:10:14 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistent (Old) and /work/SRC/openSUSE:Factory/.ghc-persistent.new.32243 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent" Wed Jan 18 13:10:14 2023 rev:36 rq:1059092 version:2.14.4.4 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistent/ghc-persistent.changes 2022-10-13 15:42:53.710825769 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-persistent.new.32243/ghc-persistent.changes 2023-01-18 13:10:37.560755243 +0100 @@ -1,0 +2,65 @@ +Thu Jan 5 16:07:36 UTC 2023 - Peter Simons <[email protected]> + +- Update persistent to version 2.14.4.4. + ## 2.14.4.4 + + * [#1460] https://github.com/yesodweb/persistent/pull/1460 + * Fix a problem where a `Primary` key causes `mkPersist` to generate code + that doesn't compile under `NoFieldSelectors` + +------------------------------------------------------------------- +Sat Dec 17 20:28:05 UTC 2022 - Peter Simons <[email protected]> + +- Update persistent to version 2.14.4.3. + ## 2.14.4.3 + + * [#1452](https://github.com/yesodweb/persistent/pull/1452) + * Implement `repsert` as a special case of `respertMany`. Allows backend + specific behavior. + +------------------------------------------------------------------- +Mon Dec 5 21:40:33 UTC 2022 - Peter Simons <[email protected]> + +- Update persistent to version 2.14.4.2. + ## 2.14.4.2 + + * [#1451](https://github.com/yesodweb/persistent/pull/1451) + * Support `mtl >= 2.3` + + ## 2.14.4.1 + + * [#1449](https://github.com/yesodweb/persistent/pull/1449) + * Default implementation for `insert_` which doesn't perform any unnecessary + queries. + +------------------------------------------------------------------- +Sat Dec 3 00:54:38 UTC 2022 - Peter Simons <[email protected]> + +- Update persistent to version 2.14.4.0. + ## 2.14.4.0 + + * [#1440](https://github.com/yesodweb/persistent/pull/1440) + * Defined NFData PersistValue + + ## 2.14.3.2 + + * [#1446](https://github.com/yesodweb/persistent/pull/1446) + * Foreign key discovery was fixed for qualified names, `Key Model`, and + `Maybe` references. + * [#1438](https://github.com/yesodweb/persistent/pull/1438) + * Clarify wording on the error message for null in unique constraint + * [#1447](https://github.com/yesodweb/persistent/pull/1447) + * Fix `SafeToInsert` not being generated correctly for some `Id` columns + + ## 2.14.3.1 + + * [#1428](https://github.com/yesodweb/persistent/pull/1428) + * Fix that the documentation for `discoverEntities` was not being generated. + +------------------------------------------------------------------- +Wed Oct 19 18:16:04 UTC 2022 - Peter Simons <[email protected]> + +- Update persistent to version 2.14.3.0 revision 1. + Upstream has revised the Cabal build instructions on Hackage. + +------------------------------------------------------------------- Old: ---- persistent-2.14.3.0.tar.gz New: ---- persistent-2.14.4.4.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistent.spec ++++++ --- /var/tmp/diff_new_pack.r6rTZJ/_old 2023-01-18 13:10:38.328759796 +0100 +++ /var/tmp/diff_new_pack.r6rTZJ/_new 2023-01-18 13:10:38.332759819 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-persistent # -# Copyright (c) 2022 SUSE LLC +# Copyright (c) 2023 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name persistent %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.14.3.0 +Version: 2.14.4.4 Release: 0 Summary: Type-safe, multi-backend data serialization License: MIT @@ -33,6 +33,7 @@ BuildRequires: ghc-bytestring-devel BuildRequires: ghc-conduit-devel BuildRequires: ghc-containers-devel +BuildRequires: ghc-deepseq-devel BuildRequires: ghc-fast-logger-devel BuildRequires: ghc-http-api-data-devel BuildRequires: ghc-lift-type-devel ++++++ persistent-2.14.3.0.tar.gz -> persistent-2.14.4.4.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/ChangeLog.md new/persistent-2.14.4.4/ChangeLog.md --- old/persistent-2.14.3.0/ChangeLog.md 2022-09-13 00:00:10.000000000 +0200 +++ new/persistent-2.14.4.4/ChangeLog.md 2023-01-05 17:07:30.000000000 +0100 @@ -1,5 +1,48 @@ # Changelog for persistent +## 2.14.4.4 + +* [#1460] https://github.com/yesodweb/persistent/pull/1460 + * Fix a problem where a `Primary` key causes `mkPersist` to generate code + that doesn't compile under `NoFieldSelectors` + +## 2.14.4.3 + +* [#1452](https://github.com/yesodweb/persistent/pull/1452) + * Implement `repsert` as a special case of `respertMany`. Allows backend + specific behavior. + +## 2.14.4.2 + +* [#1451](https://github.com/yesodweb/persistent/pull/1451) + * Support `mtl >= 2.3` + +## 2.14.4.1 + +* [#1449](https://github.com/yesodweb/persistent/pull/1449) + * Default implementation for `insert_` which doesn't perform any unnecessary + queries. + +## 2.14.4.0 + +* [#1440](https://github.com/yesodweb/persistent/pull/1440) + * Defined NFData PersistValue + +## 2.14.3.2 + +* [#1446](https://github.com/yesodweb/persistent/pull/1446) + * Foreign key discovery was fixed for qualified names, `Key Model`, and + `Maybe` references. +* [#1438](https://github.com/yesodweb/persistent/pull/1438) + * Clarify wording on the error message for null in unique constraint +* [#1447](https://github.com/yesodweb/persistent/pull/1447) + * Fix `SafeToInsert` not being generated correctly for some `Id` columns + +## 2.14.3.1 + +* [#1428](https://github.com/yesodweb/persistent/pull/1428) + * Fix that the documentation for `discoverEntities` was not being generated. + ## 2.14.3.0 * [#1425](https://github.com/yesodweb/persistent/pull/1425) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/Database/Persist/PersistValue.hs new/persistent-2.14.4.4/Database/Persist/PersistValue.hs --- old/persistent-2.14.3.0/Database/Persist/PersistValue.hs 2022-04-12 02:47:40.000000000 +0200 +++ new/persistent-2.14.4.4/Database/Persist/PersistValue.hs 2022-12-03 01:54:05.000000000 +0100 @@ -11,6 +11,7 @@ , LiteralType(..) ) where +import Control.DeepSeq import qualified Data.ByteString.Base64 as B64 import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Char8 as BS8 @@ -70,6 +71,27 @@ -- @since 2.12.0.0 deriving (Show, Read, Eq, Ord) +-- | +-- @since 2.14.4.0 +instance NFData PersistValue where + rnf val = case val of + PersistText txt -> rnf txt + PersistByteString bs -> rnf bs + PersistInt64 i -> rnf i + PersistDouble d -> rnf d + PersistRational q -> rnf q + PersistBool b -> rnf b + PersistDay d -> rnf d + PersistTimeOfDay t -> rnf t + PersistUTCTime t -> rnf t + PersistNull -> () + PersistList vals -> rnf vals + PersistMap vals -> rnf vals + PersistObjectId bs -> rnf bs + PersistArray vals -> rnf vals + PersistLiteral_ ty bs -> ty `seq` rnf bs + + -- | A type that determines how a backend should handle the literal. -- -- @since 2.12.0.0 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/Database/Persist/Sql/Orphan/PersistStore.hs new/persistent-2.14.4.4/Database/Persist/Sql/Orphan/PersistStore.hs --- old/persistent-2.14.3.0/Database/Persist/Sql/Orphan/PersistStore.hs 2022-04-12 02:47:14.000000000 +0200 +++ new/persistent-2.14.4.4/Database/Persist/Sql/Orphan/PersistStore.hs 2022-12-17 21:27:59.000000000 +0100 @@ -159,6 +159,18 @@ rawExecute sql $ map updatePersistValue upds `mappend` keyToValues k + insert_ val = do + conn <- ask + let vals = mkInsertValues val + case connInsertSql conn (entityDef (Just val)) vals of + ISRSingle sql -> do + withRawQuery sql vals $ do + pure () + ISRInsertGet sql1 _sql2 -> do + rawExecute sql1 vals + ISRManyKeys sql _fs -> do + rawExecute sql vals + insert val = do conn <- ask let esql = connInsertSql conn t vals @@ -276,11 +288,7 @@ where go = insrepHelper "INSERT" - repsert key value = do - mExisting <- get key - case mExisting of - Nothing -> insertKey key value - Just _ -> replace key value + repsert key value = repsertMany [(key, value)] repsertMany [] = return () repsertMany krsDups = do @@ -295,7 +303,13 @@ Just _ -> mkInsertValues r case connRepsertManySql conn of (Just mkSql) -> rawExecute (mkSql ent nr) (concatMap toVals krs) - Nothing -> mapM_ (uncurry repsert) krs + Nothing -> mapM_ repsert' krs + where + repsert' (key, value) = do + mExisting <- get key + case mExisting of + Nothing -> insertKey key value + Just _ -> replace key value delete k = do conn <- ask diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/Database/Persist/Sql/Run.hs new/persistent-2.14.4.4/Database/Persist/Sql/Run.hs --- old/persistent-2.14.3.0/Database/Persist/Sql/Run.hs 2022-04-27 15:58:51.000000000 +0200 +++ new/persistent-2.14.4.4/Database/Persist/Sql/Run.hs 2022-12-05 22:40:29.000000000 +0100 @@ -5,7 +5,8 @@ import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack -import Control.Monad.Reader (MonadReader, void) +import Control.Monad (void) +import Control.Monad.Reader (MonadReader) import qualified Control.Monad.Reader as MonadReader import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/Database/Persist/TH.hs new/persistent-2.14.4.4/Database/Persist/TH.hs --- old/persistent-2.14.3.0/Database/Persist/TH.hs 2022-08-24 17:43:30.000000000 +0200 +++ new/persistent-2.14.4.4/Database/Persist/TH.hs 2023-01-05 17:07:30.000000000 +0100 @@ -20,6 +20,11 @@ -- | This module provides the tools for defining your database schema and using -- it to generate Haskell data types and migrations. +-- +-- For documentation on the domain specific language used for defining database +-- models, see "Database.Persist.Quasi". +-- +-- module Database.Persist.TH ( -- * Parse entity defs persistWith @@ -30,7 +35,11 @@ -- * Turn @EntityDef@s into types , mkPersist , mkPersistWith + -- ** Configuring Entity Definition , MkPersistSettings + , mkPersistSettings + , sqlSettings + -- *** Record Fields (for update/viewing settings) , mpsBackend , mpsGeneric , mpsPrefixFields @@ -41,8 +50,6 @@ , mpsDeriveInstances , mpsCamelCaseCompositeKeySelector , EntityJSON(..) - , mkPersistSettings - , sqlSettings -- ** Implicit ID Columns , ImplicitIdDef , setImplicitIdDef @@ -72,9 +79,8 @@ import Control.Monad import Data.Aeson - ( FromJSON(parseJSON) - , ToJSON(toJSON) - , Value(Object) + ( FromJSON(..) + , ToJSON(..) , eitherDecodeStrict' , object , withObject @@ -111,7 +117,7 @@ import Instances.TH.Lift () -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` -import Data.Foldable (toList) +import Data.Foldable (asum, toList) import qualified Data.Set as Set import Language.Haskell.TH.Lib (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) @@ -193,8 +199,7 @@ -- -- @ -- -- Migrate.hs --- 'share' --- ['mkMigrate' "migrateAll"] +-- 'mkMigrate' "migrateAll" -- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) -- @ -- @@ -282,10 +287,6 @@ (embedEntityMap, noCycleEnts) = embedEntityDefsMap preexistingEntities unboundDefs -stripId :: FieldType -> Maybe Text -stripId (FTTypeCon Nothing t) = stripSuffix "Id" t -stripId _ = Nothing - liftAndFixKeys :: MkPersistSettings -> M.Map EntityNameHS a @@ -513,13 +514,22 @@ guessReference :: FieldType -> Maybe EntityNameHS guessReference ft = - case ft of - FTTypeCon Nothing (T.stripSuffix "Id" -> Just tableName) -> - Just (EntityNameHS tableName) - FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing tableName) -> - Just (EntityNameHS tableName) - _ -> - Nothing + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon _ (checkIdSuffix -> Just tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] mkDefaultKey :: MkPersistSettings @@ -691,7 +701,18 @@ lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS lookupEmbedEntity allEntities field = do - entName <- EntityNameHS <$> stripId (fieldType field) + let mfieldTy = Just $ fieldType field + entName <- EntityNameHS <$> asum + [ do + FTTypeCon _ t <- mfieldTy + stripSuffix "Id" t + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- mfieldTy + pure entName + , do + FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- mfieldTy + stripSuffix "Id" t + ] guard (M.member entName allEntities) -- check entity name exists in embed fmap pure entName @@ -730,6 +751,8 @@ Left $ Just $ FTKeyCon $ a <> "Id" mEmbedded _ (FTApp _ _) = Left Nothing +mEmbedded _ (FTLit _) = + Left Nothing setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef setEmbedField entName allEntities field = @@ -757,14 +780,89 @@ setFieldReference ref field = field { fieldReference = ref } -- | Create data types and appropriate 'PersistEntity' instances for the given --- 'EntityDef's. Works well with the persist quasi-quoter. +-- 'UnboundEntityDef's. +-- +-- This function should be used if you are only defining a single block of +-- Persistent models for the entire application. If you intend on defining +-- multiple blocks in different fiels, see 'mkPersistWith' which allows you +-- to provide existing entity definitions so foreign key references work. +-- +-- Example: +-- +-- @ +-- mkPersist 'sqlSettings' ['persistLowerCase'| +-- User +-- name Text +-- age Int +-- +-- Dog +-- name Text +-- owner UserId +-- +-- |] +-- @ +-- +-- Example from a file: +-- +-- @ +-- mkPersist 'sqlSettings' $('persistFileWith' 'lowerCaseSettings' "models.persistentmodels") +-- @ +-- +-- For full information on the 'QuasiQuoter' syntax, see +-- "Database.Persist.Quasi" documentation. mkPersist :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec] mkPersist mps = mkPersistWith mps [] --- | Like ' +-- | Like 'mkPersist', but allows you to provide a @['EntityDef']@ +-- representing the predefined entities. This function will include those +-- 'EntityDef' when looking for foreign key references. +-- +-- You should use this if you intend on defining Persistent models in +-- multiple files. +-- +-- Suppose we define a table @Foo@ which has no dependencies. +-- +-- @ +-- module DB.Foo where +-- +-- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'| +-- Foo +-- name Text +-- |] +-- @ +-- +-- Then, we define a table @Bar@ which depends on @Foo@: +-- +-- @ +-- module DB.Bar where +-- +-- import DB.Foo +-- +-- 'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'| +-- Bar +-- fooId FooId +-- |] +-- @ +-- +-- Writing out the list of 'EntityDef' can be annoying. The +-- @$('discoverEntities')@ shortcut will work to reduce this boilerplate. +-- +-- @ +-- module DB.Quux where +-- +-- import DB.Foo +-- import DB.Bar +-- +-- 'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'| +-- Quux +-- name Text +-- fooId FooId +-- barId BarId +-- |] +-- @ -- -- @since 2.13.0.0 mkPersistWith @@ -822,11 +920,15 @@ True _ -> False - case List.find isDefaultFieldAttr attrs of + case unboundIdType uidDef of Nothing -> - badInstance - Just _ -> instanceOkay + Just _ -> + case List.find isDefaultFieldAttr attrs of + Nothing -> + badInstance + Just _ -> do + instanceOkay DefaultKey _ -> instanceOkay @@ -1129,7 +1231,7 @@ cols = do fieldDef <- getUnboundFieldDefs entDef let - recordName = + recordNameE = fieldDefToRecordName mps entDef fieldDef strictness = if unboundFieldStrict fieldDef @@ -1137,7 +1239,7 @@ else notStrict fieldIdType = maybeIdType mps entityMap fieldDef Nothing Nothing - pure (recordName, strictness, fieldIdType) + pure (recordNameE, strictness, fieldIdType) constrs | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef @@ -1185,13 +1287,14 @@ lookup3 x rest nullErrMsg = - mconcat [ "Error: By default we disallow NULLables in an uniqueness " - , "constraint. The semantics of how NULL interacts with those " - , "constraints is non-trivial: two NULL values are not " - , "considered equal for the purposes of an uniqueness " - , "constraint. If you understand this feature, it is possible " - , "to use it your advantage. *** Use a \"!force\" attribute " - , "on the end of the line that defines your uniqueness " + mconcat [ "Error: By default Persistent disallows NULLables in an uniqueness " + , "constraint. The semantics of how NULL interacts with those constraints " + , "is non-trivial: most SQL implementations will not consider two NULL " + , "values to be equal for the purposes of an uniqueness constraint, " + , "allowing insertion of more than one row with a NULL value for the " + , "column in question. If you understand this feature of SQL and still " + , "intend to add a uniqueness constraint here, *** Use a \"!force\" " + , "attribute on the end of the line that defines your uniqueness " , "constraint in order to disable this check. ***" ] -- | This function renders a Template Haskell 'Type' for an 'UnboundFieldDef'. @@ -1505,11 +1608,9 @@ [ if k == name then (name, new) else (k, VarE k) | k <- names ] - pats = [ (k, VarP k) | k <- names, k /= name] - mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause] -mkLensClauses mps entDef genDataType = do +mkLensClauses mps entDef _genDataType = do lens' <- [|lensPTH|] getId <- [|entityKey|] setId <- [|\(Entity _ value) key -> Entity key value|] @@ -1732,12 +1833,12 @@ mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec mkKeyToValues mps entDef = do - recordName <- newName "record" + recordN <- newName "record" FunD 'keyToValues . pure <$> case unboundPrimarySpec entDef of NaturalKey ucd -> do - normalClause [VarP recordName] <$> - toValuesPrimary recordName ucd + normalClause [VarP recordN] <$> + toValuesPrimary recordN ucd _ -> do normalClause [] <$> [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|] @@ -1746,8 +1847,10 @@ ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd) f recName fieldNameHS = [| - toPersistValue ($(varE $ keyFieldName mps entDef fieldNameHS) $(varE recName)) + toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE recName)) |] + keyFieldSel name + = fieldSel (keyConName entDef) (keyFieldName mps entDef name) normalClause :: [Pat] -> Exp -> Clause normalClause p e = Clause p (NormalB e) [] @@ -1891,7 +1994,6 @@ [keyFromRecordM'] <- case unboundPrimarySpec entDef of NaturalKey ucd -> do - recordName <- newName "record" let keyCon = keyConName entDef @@ -1901,15 +2003,11 @@ foldl' AppE (ConE keyCon) - (toList $ fmap - (\n -> - VarE n `AppE` VarE recordName - ) - keyFields' - ) + (VarE <$> keyFields') keyFromRec = varP 'keyFromRecordM + lam = LamE [RecP name [(n, VarP n) | n <- toList keyFields']] constr [d| - $(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr)) + $(keyFromRec) = Just $(pure lam) |] _ -> @@ -1927,8 +2025,8 @@ let names'types = filter (\(n, _) -> n /= mkName "Id") $ map (getConNameAndType . entityFieldTHCon) $ entityFieldsTHFields fields getConNameAndType = \case - ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name []) -> - (name, fieldTy) + ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC conName []) -> + (conName, fieldTy) other -> error $ mconcat [ "persistent internal error: field constructor did not have xpected shape. \n" @@ -2230,16 +2328,10 @@ -> TyVarBndr () mkPlainTV n = PlainTV n () -mkDoE :: [Stmt] -> Exp -mkDoE stmts = DoE Nothing stmts - mkForallTV :: Name -> TyVarBndr Specificity mkForallTV n = PlainTV n SpecifiedSpec #else -mkDoE :: [Stmt] -> Exp -mkDoE = DoE - mkPlainTV :: Name -> TyVarBndr @@ -2272,13 +2364,13 @@ fieldStore = mkFieldStore entDef - recordName <- newName "record_mkForeignKeysComposite" + recordVarName <- newName "record_mkForeignKeysComposite" let mkFldE foreignName = -- using coerce here to convince SqlBackendKey to go away VarE 'coerce `AppE` - (VarE (fieldName foreignName) `AppE` VarE recordName) + (VarE (fieldName foreignName) `AppE` VarE recordVarName) mkFldR ffr = let e = @@ -2315,7 +2407,7 @@ mkKeyE = foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE fn = - FunD fname [normalClause [VarP recordName] mkKeyE] + FunD fname [normalClause [VarP recordVarName] mkKeyE] keyTargetTable = maybeTyp fNullable $ ConT ''Key `AppT` ConT (mkName reftableString) @@ -2397,7 +2489,24 @@ -- -- This function is useful for cases such as: -- --- >>> share [mkEntityDefList "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] +-- @ +-- share ['mkEntityDefList' "myDefs", 'mkPersist' sqlSettings] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- If you only have a single function, though, you don't need this. The +-- following is redundant: +-- +-- @ +-- 'share' ['mkPersist' 'sqlSettings'] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- Most functions require a full @['EntityDef']@, which can be provided +-- using @$('discoverEntities')@ for all entites in scope, or defining +-- 'mkEntityDefList' to define a list of entities from the given block. share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec] share fs x = mconcat <$> mapM ($ x) fs @@ -2455,7 +2564,8 @@ go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp go' xs front col = - let Just col' = lookup col xs + let col' = + fromMaybe (error $ "failed in go' while looking up col=" <> show col) (lookup col xs) in front `AppE` VarE col' sqlTypeFunD :: Exp -> Dec @@ -3147,60 +3257,62 @@ entityName = unEntityNameHS entity fieldName = upperFirst $ unFieldNameHS field --- | Splice in a list of all 'EntityDef' in scope. This is useful when running --- 'mkPersist' to ensure that all entity definitions are available for setting --- foreign keys, and for performing migrations with all entities available. --- --- 'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to --- account for entities defined elsewhere, you'll @mappend $(discoverEntities)@. --- --- For example, --- --- @ --- share --- [ mkPersistWith sqlSettings $(discoverEntities) --- ] --- [persistLowerCase| ... |] --- @ --- --- Likewise, to run migrations with all entity instances in scope, you'd write: --- --- @ --- migrateAll = migrateModels $(discoverEntities) --- @ --- --- Note that there is some odd behavior with Template Haskell and splicing --- groups. If you call 'discoverEntities' in the same module that defines --- 'PersistEntity' instances, you need to ensure they are in different top-level --- binding groups. You can write @$(pure [])@ at the top level to do this. --- --- @ --- -- Foo and Bar both export an instance of PersistEntity --- import Foo --- import Bar --- --- -- Since Foo and Bar are both imported, discoverEntities can find them here. --- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| --- User --- name Text --- age Int --- |] --- --- -- onlyFooBar is defined in the same 'top level group' as the above generated --- -- instance for User, so it isn't present in this list. --- onlyFooBar :: [EntityDef] --- onlyFooBar = $(discoverEntities) --- --- -- We can manually create a new binding group with this, which splices an --- -- empty list of declarations in. --- $(pure []) --- --- -- fooBarUser is able to see the 'User' instance. --- fooBarUser :: [EntityDef] --- fooBarUser = $(discoverEntities) --- @ --- --- @since 2.13.0.0 +{-| +Splice in a list of all 'EntityDef' in scope. This is useful when running +'mkPersist' to ensure that all entity definitions are available for setting +foreign keys, and for performing migrations with all entities available. + +'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to +account for entities defined elsewhere, you'll @mappend $(discoverEntities)@. + +For example, + +@ +share + [ mkPersistWith sqlSettings $(discoverEntities) + ] + [persistLowerCase| ... |] +@ + +Likewise, to run migrations with all entity instances in scope, you'd write: + +@ +migrateAll = migrateModels $(discoverEntities) +@ + +Note that there is some odd behavior with Template Haskell and splicing +groups. If you call 'discoverEntities' in the same module that defines +'PersistEntity' instances, you need to ensure they are in different top-level +binding groups. You can write @$(pure [])@ at the top level to do this. + +@ +-- Foo and Bar both export an instance of PersistEntity +import Foo +import Bar + +-- Since Foo and Bar are both imported, discoverEntities can find them here. +mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| + User + name Text + age Int + |] + +-- onlyFooBar is defined in the same 'top level group' as the above generated +-- instance for User, so it isn't present in this list. +onlyFooBar :: [EntityDef] +onlyFooBar = $(discoverEntities) + +-- We can manually create a new binding group with this, which splices an +-- empty list of declarations in. +$(pure []) + +-- fooBarUser is able to see the 'User' instance. +fooBarUser :: [EntityDef] +fooBarUser = $(discoverEntities) +@ + +@since 2.13.0.0 +-} discoverEntities :: Q Exp discoverEntities = do instances <- reifyInstances ''PersistEntity [VarT (mkName "a")] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/Database/Persist/Types/Base.hs new/persistent-2.14.4.4/Database/Persist/Types/Base.hs --- old/persistent-2.14.3.0/Database/Persist/Types/Base.hs 2022-08-23 01:51:59.000000000 +0200 +++ new/persistent-2.14.4.4/Database/Persist/Types/Base.hs 2022-12-03 01:05:06.000000000 +0100 @@ -288,11 +288,11 @@ -- newName Text -- @ | FieldAttrNoreference - -- ^ This attribute indicates that we should create a foreign key reference - -- from a column. By default, @persistent@ will try and create a foreign key - -- reference for a column if it can determine that the type of the column is - -- a @'Key' entity@ or an @EntityId@ and the @Entity@'s name was present in - -- 'mkPersist'. + -- ^ This attribute indicates that we should not create a foreign key + -- reference from a column. By default, @persistent@ will try and create a + -- foreign key reference for a column if it can determine that the type of + -- the column is a @'Key' entity@ or an @EntityId@ and the @Entity@'s name + -- was present in 'mkPersist'. -- -- This is useful if you want to use the explicit foreign key syntax. -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/persistent.cabal new/persistent-2.14.4.4/persistent.cabal --- old/persistent-2.14.3.0/persistent.cabal 2022-09-13 00:00:10.000000000 +0200 +++ new/persistent-2.14.4.4/persistent.cabal 2023-01-05 17:07:30.000000000 +0100 @@ -1,5 +1,5 @@ name: persistent -version: 2.14.3.0 +version: 2.14.4.4 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]> @@ -17,24 +17,25 @@ library build-depends: base >= 4.11.1.0 && < 5 - , aeson >= 1.0 && < 2.1 + , aeson >= 1.0 && < 2.2 , attoparsec , base64-bytestring , blaze-html >= 0.9 , bytestring >= 0.10 - , conduit >= 1.2.12 + , conduit >= 1.3 , containers >= 0.5 + , deepseq , fast-logger >= 2.4 , http-api-data >= 0.3 , lift-type >= 0.1.0.0 && < 0.2.0.0 , monad-logger >= 0.3.28 - , mtl < 2.3 + , mtl , path-pieces >= 0.2 , resource-pool >= 0.2.3 , resourcet >= 1.1.10 , scientific , silently - , template-haskell >= 2.13 && < 2.19 + , template-haskell >= 2.13 && < 2.20 , text >= 1.2 , th-lift-instances >= 0.1.14 && < 0.2 , time >= 1.6 @@ -111,7 +112,7 @@ Database.Persist.Compatible.Types Database.Persist.Compatible.TH - ghc-options: -Wall + ghc-options: -Wall -Werror=incomplete-patterns default-language: Haskell2010 test-suite test @@ -127,6 +128,7 @@ , bytestring , conduit , containers + , deepseq , fast-logger , hspec >= 2.4 , http-api-data @@ -160,6 +162,7 @@ , MultiParamTypeClasses , OverloadedStrings , TypeFamilies + , TypeOperators other-modules: Database.Persist.ClassSpec diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/test/Database/Persist/TH/NoFieldSelectorsSpec.hs new/persistent-2.14.4.4/test/Database/Persist/TH/NoFieldSelectorsSpec.hs --- old/persistent-2.14.3.0/test/Database/Persist/TH/NoFieldSelectorsSpec.hs 2022-08-23 01:51:59.000000000 +0200 +++ new/persistent-2.14.4.4/test/Database/Persist/TH/NoFieldSelectorsSpec.hs 2023-01-05 17:07:30.000000000 +0100 @@ -21,7 +21,10 @@ mkPersist sqlSettings {mpsFieldLabelModifier = const id} [persistLowerCase| User + ident Text name Text + Primary ident + team TeamId Team name Text diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/test/Database/Persist/TH/PersistWith/Model.hs new/persistent-2.14.4.4/test/Database/Persist/TH/PersistWith/Model.hs --- old/persistent-2.14.3.0/test/Database/Persist/TH/PersistWith/Model.hs 2022-04-12 02:47:14.000000000 +0200 +++ new/persistent-2.14.4.4/test/Database/Persist/TH/PersistWith/Model.hs 2022-12-03 01:05:06.000000000 +0100 @@ -16,11 +16,12 @@ import TemplateTestImports -import Database.Persist.TH.PersistWith.Model2 +import Database.Persist.TH.PersistWith.Model2 as Model2 mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| IceCream flavor FlavorId + otherFlavor Model2.FlavorId |] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/test/Database/Persist/TH/PersistWithSpec.hs new/persistent-2.14.4.4/test/Database/Persist/TH/PersistWithSpec.hs --- old/persistent-2.14.3.0/test/Database/Persist/TH/PersistWithSpec.hs 2022-04-12 02:47:14.000000000 +0200 +++ new/persistent-2.14.4.4/test/Database/Persist/TH/PersistWithSpec.hs 2022-12-03 01:05:06.000000000 +0100 @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,26 +15,60 @@ module Database.Persist.TH.PersistWithSpec where +import Control.Monad import TemplateTestImports -import Database.Persist.TH.PersistWith.Model (IceCreamId) -import Data.List (find) +import Database.Persist.TH.PersistWith.Model as Model (IceCream, IceCreamId) import Language.Haskell.TH as TH mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| BestTopping iceCream IceCreamId + otherCream Model.IceCreamId + keyCream (Key IceCream) + qualifiedKeyCream (Key Model.IceCream) + nullableCream IceCreamId Maybe + maybeCream (Maybe IceCreamId) + maybeQualifiedCream (Maybe Model.IceCreamId) + maybeQualifiedKeyCream (Maybe (Key Model.IceCream)) + maybeKeyCream (Maybe (Key IceCream)) |] +deriving instance Show (EntityField BestTopping a) +deriving instance Eq (EntityField BestTopping a) + +data SomeField where + SomeField :: EntityField BestTopping a -> SomeField + +allFields = + [ SomeField BestToppingIceCream + , SomeField BestToppingOtherCream + , SomeField BestToppingKeyCream + , SomeField BestToppingQualifiedKeyCream + , SomeField BestToppingMaybeCream + , SomeField BestToppingNullableCream + , SomeField BestToppingMaybeQualifiedCream + , SomeField BestToppingMaybeQualifiedKeyCream + , SomeField BestToppingMaybeKeyCream + ] + spec :: Spec spec = describe "mkPersistWith" $ do - it "works" $ do - let - edef = - entityDef (Proxy @BestTopping) - Just iceCreamField = - find ((FieldNameHS "iceCream" ==) . fieldHaskell) (getEntityFields edef) - fieldReference iceCreamField - `shouldBe` - ForeignRef (EntityNameHS "IceCream") + describe "finds references" $ do + forM_ allFields $ \(SomeField field) -> + it (show field) (shouldReferToIceCream field) + +shouldReferToIceCream :: EntityField BestTopping a -> IO () +shouldReferToIceCream field = + unless (reference == iceCreamRef) $ do + expectationFailure $ mconcat + [ "The field '", show field, "' does not have a reference to IceCream.\n" + , "Got Reference: ", show reference, "\n" + , "Expected : ", show iceCreamRef + ] + where + reference = + fieldReference (persistFieldDef field) + iceCreamRef = + ForeignRef (EntityNameHS "IceCream") diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.14.3.0/test/Database/Persist/THSpec.hs new/persistent-2.14.4.4/test/Database/Persist/THSpec.hs --- old/persistent-2.14.3.0/test/Database/Persist/THSpec.hs 2022-08-24 17:43:30.000000000 +0200 +++ new/persistent-2.14.4.4/test/Database/Persist/THSpec.hs 2022-12-05 19:00:17.000000000 +0100 @@ -96,6 +96,11 @@ NoJson foo Text deriving Show Eq + +CustomIdName + Id sql=id_col + name Text + deriving Show Eq |] mkPersist sqlSettings [persistLowerCase| @@ -484,6 +489,11 @@ , addressZip = Nothing } + describe "CustomIdName" $ do + it "has a good safe to insert class instance" $ do + let proxy = Proxy :: SafeToInsert CustomIdName => Proxy CustomIdName + proxy `shouldBe` Proxy + (&) :: a -> (a -> b) -> b x & f = f x
