persistent 2.14.3.0 → 2.14.3.2
raw patch · 7 files changed
+299/−129 lines, 7 files
Files
- ChangeLog.md +15/−0
- Database/Persist/TH.hs +216/−108
- Database/Persist/Types/Base.hs +5/−5
- persistent.cabal +5/−4
- test/Database/Persist/TH/PersistWith/Model.hs +2/−1
- test/Database/Persist/TH/PersistWithSpec.hs +46/−11
- test/Database/Persist/THSpec.hs +10/−0
ChangeLog.md view
@@ -1,5 +1,20 @@ # Changelog for persistent +## 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)
Database/Persist/TH.hs view
@@ -72,9 +72,8 @@ import Control.Monad import Data.Aeson- ( FromJSON(parseJSON)- , ToJSON(toJSON)- , Value(Object)+ ( FromJSON(..)+ , ToJSON(..) , eitherDecodeStrict' , object , withObject@@ -111,7 +110,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 +192,7 @@ -- -- @ -- -- Migrate.hs--- 'share'--- ['mkMigrate' "migrateAll"]+-- 'mkMigrate' "migrateAll" -- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) -- @ --@@ -282,10 +280,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 +507,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 +694,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 +744,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,15 +773,90 @@ 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 :: MkPersistSettings@@ -822,11 +913,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 +1224,7 @@ cols = do fieldDef <- getUnboundFieldDefs entDef let- recordName =+ recordNameE = fieldDefToRecordName mps entDef fieldDef strictness = if unboundFieldStrict fieldDef@@ -1137,7 +1232,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 +1280,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 +1601,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 +1826,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)|]@@ -1891,7 +1985,7 @@ [keyFromRecordM'] <- case unboundPrimarySpec entDef of NaturalKey ucd -> do- recordName <- newName "record"+ recordVarName <- newName "record" let keyCon = keyConName entDef@@ -1903,13 +1997,13 @@ (ConE keyCon) (toList $ fmap (\n ->- VarE n `AppE` VarE recordName+ VarE n `AppE` VarE recordVarName ) keyFields' ) keyFromRec = varP 'keyFromRecordM [d|- $(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr))+ $(keyFromRec) = Just ( \ $(varP recordVarName) -> $(pure constr)) |] _ ->@@ -1927,8 +2021,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 +2324,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 +2360,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 +2403,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 +2485,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 +2560,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 +3253,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")]
Database/Persist/Types/Base.hs view
@@ -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. --
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.14.3.0+version: 2.14.3.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -17,7 +17,7 @@ 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@@ -34,7 +34,7 @@ , 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 +111,7 @@ Database.Persist.Compatible.Types Database.Persist.Compatible.TH - ghc-options: -Wall+ ghc-options: -Wall -Werror=incomplete-patterns default-language: Haskell2010 test-suite test@@ -160,6 +160,7 @@ , MultiParamTypeClasses , OverloadedStrings , TypeFamilies+ , TypeOperators other-modules: Database.Persist.ClassSpec
test/Database/Persist/TH/PersistWith/Model.hs view
@@ -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 |]
test/Database/Persist/TH/PersistWithSpec.hs view
@@ -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")
test/Database/Persist/THSpec.hs view
@@ -96,6 +96,11 @@ NoJson foo Text deriving Show Eq++CustomIdName+ Id sql=id_col+ name Text+ deriving Show Eq |] mkPersist sqlSettings [persistLowerCase|@@ -483,6 +488,11 @@ , addressCity = "Denver" , 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