From bb0b3523edb886f0325641da200e5f31ba002416 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 17 Jun 2021 15:24:58 -0600 Subject: [PATCH 1/6] Fix duplicate entity checks --- persistent/persistent.cabal | 3 ++ .../Database/Persist/TH/PersistWith/Model.hs | 26 +++++++++++++ .../Database/Persist/TH/PersistWith/Model2.hs | 24 ++++++++++++ .../Database/Persist/TH/PersistWithSpec.hs | 39 +++++++++++++++++++ .../TH/SharedPrimaryKeyImportedSpec.hs | 20 +++++++++- persistent/test/Database/Persist/THSpec.hs | 3 ++ 6 files changed, 114 insertions(+), 1 deletion(-) create mode 100644 persistent/test/Database/Persist/TH/PersistWith/Model.hs create mode 100644 persistent/test/Database/Persist/TH/PersistWith/Model2.hs create mode 100644 persistent/test/Database/Persist/TH/PersistWithSpec.hs diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index b3a95981d..dd3ab9bbb 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -164,6 +164,9 @@ test-suite test Database.Persist.TH.DiscoverEntitiesSpec Database.Persist.TH.EmbedSpec Database.Persist.TH.ForeignRefSpec + Database.Persist.TH.PersistWith.Model + Database.Persist.TH.PersistWith.Model2 + Database.Persist.TH.PersistWithSpec Database.Persist.TH.ImplicitIdColSpec Database.Persist.TH.JsonEncodingSpec Database.Persist.TH.KindEntitiesSpec diff --git a/persistent/test/Database/Persist/TH/PersistWith/Model.hs b/persistent/test/Database/Persist/TH/PersistWith/Model.hs new file mode 100644 index 000000000..2c730bec8 --- /dev/null +++ b/persistent/test/Database/Persist/TH/PersistWith/Model.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.PersistWith.Model where + +import TemplateTestImports + +import Database.Persist.TH.PersistWith.Model2 + +mkPersist sqlSettings [persistLowerCase| + +IceCream + flavor FlavorId + +|] diff --git a/persistent/test/Database/Persist/TH/PersistWith/Model2.hs b/persistent/test/Database/Persist/TH/PersistWith/Model2.hs new file mode 100644 index 000000000..6b3960746 --- /dev/null +++ b/persistent/test/Database/Persist/TH/PersistWith/Model2.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.PersistWith.Model2 where + +import TemplateTestImports + +mkPersist sqlSettings [persistLowerCase| + +Flavor + name Text + +|] diff --git a/persistent/test/Database/Persist/TH/PersistWithSpec.hs b/persistent/test/Database/Persist/TH/PersistWithSpec.hs new file mode 100644 index 000000000..4ddc94ac0 --- /dev/null +++ b/persistent/test/Database/Persist/TH/PersistWithSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.PersistWithSpec where + +import TemplateTestImports +import Database.Persist.TH.PersistWith.Model +import Data.List (find) + +mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| + +BestTopping + iceCream IceCreamId + +|] + +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") + diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs index 071069614..179fdf543 100644 --- a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs @@ -21,10 +21,17 @@ import Database.Persist import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH +import Language.Haskell.TH +import Control.Monad.IO.Class import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) -share [ mkPersist sqlSettings ] [persistLowerCase| +share + [ mkPersistWith sqlSettings [entityDef (Proxy @User)] + , \_ -> do + liftIO $ traverse (print . getEntityHaskellName) $(discoverEntities) + pure [] + ] [persistLowerCase| Profile Id UserId @@ -57,3 +64,14 @@ spec = describe "Shared Primary Keys Imported" $ do getSqlType (Proxy @User) `shouldBe` getSqlType (Proxy @Profile) + + + describe "foreign reference should work" $ do + it "should have a foreign reference" $ do + let + Just fd = + getEntityIdField (entityDef (Proxy @Profile)) + fieldReference fd + `shouldBe` + (ForeignRef (EntityNameHS "User")) + diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 422bc0dd9..94d0595a4 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -45,6 +45,8 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports + +import qualified Database.Persist.TH.PersistWithSpec as PersistWithSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec @@ -171,6 +173,7 @@ instance Arbitrary Address where spec :: Spec spec = describe "THSpec" $ do + PersistWithSpec.spec KindEntitiesSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec From a049306617c1413e2c39856728318fa7212e1438 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 17 Jun 2021 15:48:37 -0600 Subject: [PATCH 2/6] Fix the issue --- persistent/Database/Persist/Quasi/Internal.hs | 16 ++++++++-------- persistent/Database/Persist/TH.hs | 8 +++++--- .../Persist/TH/SharedPrimaryKeyImportedSpec.hs | 7 ++----- 3 files changed, 15 insertions(+), 16 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 6f4421916..a89c2b929 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -416,7 +416,7 @@ data UnboundEntityDef -- -- @since 2.13.0.0 } - deriving (Show, Lift) + deriving (Eq, Ord, Show, Lift) -- | Convert an 'EntityDef' into an 'UnboundEntityDef'. This "forgets" -- information about the 'EntityDef', but it is all kept present on the @@ -537,7 +537,7 @@ data UnboundFieldDef -- -- @since 2.13.0.0 } - deriving (Eq, Show, Lift) + deriving (Eq, Ord, Show, Lift) -- | Forget innformation about a 'FieldDef' so it can beused as an -- 'UnboundFieldDef'. @@ -615,7 +615,7 @@ data PrimarySpec -- have a 'DefaultKey'. -- -- @since 2.13.0.0 - deriving (Show, Lift) + deriving (Eq, Ord, Show, Lift) -- | Construct an entity definition. mkUnboundEntityDef @@ -964,7 +964,7 @@ data UnboundIdDef = UnboundIdDef , unboundIdCascade :: FieldCascade , unboundIdType :: Maybe FieldType } - deriving (Show, Lift) + deriving (Eq, Ord, Show, Lift) -- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. -- need to re-work takeCols function @@ -1009,7 +1009,7 @@ data UnboundCompositeDef = UnboundCompositeDef -- -- @since 2.13.0.0 } - deriving (Show, Lift) + deriving (Eq, Ord, Show, Lift) takeComposite :: [FieldNameHS] @@ -1130,7 +1130,7 @@ data UnboundForeignDef -- -- @since 2.13.0.0 } - deriving (Eq, Show, Lift) + deriving (Eq, Ord, Show, Lift) -- | A list of fields present on the foreign reference. data UnboundForeignFieldList @@ -1158,7 +1158,7 @@ data UnboundForeignFieldList -- @ -- -- @since 2.13.0.0 - deriving (Eq, Show, Lift) + deriving (Eq, Ord, Show, Lift) -- | A pairing of the 'FieldNameHS' for the source table to the 'FieldNameHS' -- for the target table. @@ -1175,7 +1175,7 @@ data ForeignFieldReference = -- -- @since 2.13.0.0 } - deriving (Eq, Show, Lift) + deriving (Eq, Ord, Show, Lift) unbindForeignDef :: ForeignDef -> UnboundForeignDef unbindForeignDef fd = diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 108d52d01..f4ac92b56 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -237,8 +237,6 @@ embedEntityDefsMap existingEnts rawEnts = (embedEntityMap, noCycleEnts) where noCycleEnts = entsWithEmbeds - -- every EntityDef could reference each-other (as an EmbedRef) - -- let Haskell tie the knot embedEntityMap = constructEmbedEntityMap entsWithEmbeds entsWithEmbeds = fmap setEmbedEntity (rawEnts <> map unbindEntityDef existingEnts) setEmbedEntity ubEnt = @@ -773,7 +771,11 @@ mkPersistWith mps preexistingEntities ents' = do $ predefs entityMap = constructEntityMap allEnts - ents <- filterM shouldGenerateCode allEnts + newEnts = + Set.toList $ + Set.fromList allEnts + Set.\\ Set.fromList (map unbindEntityDef preexistingEntities) + ents <- filterM shouldGenerateCode newEnts requireExtensions [ [TypeFamilies], [GADTs, ExistentialQuantification] , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs index 179fdf543..f0f8e1f61 100644 --- a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs @@ -28,9 +28,6 @@ import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) share [ mkPersistWith sqlSettings [entityDef (Proxy @User)] - , \_ -> do - liftIO $ traverse (print . getEntityHaskellName) $(discoverEntities) - pure [] ] [persistLowerCase| Profile @@ -68,10 +65,10 @@ spec = describe "Shared Primary Keys Imported" $ do describe "foreign reference should work" $ do it "should have a foreign reference" $ do + pendingWith "issue #1289" let Just fd = getEntityIdField (entityDef (Proxy @Profile)) fieldReference fd `shouldBe` - (ForeignRef (EntityNameHS "User")) - + ForeignRef (EntityNameHS "User") From 9e4d31da839d59989cb52edb9495e8bc91e169be Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 17 Jun 2021 15:50:00 -0600 Subject: [PATCH 3/6] nice --- .../test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs index f0f8e1f61..bf1a455c2 100644 --- a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs @@ -26,9 +26,7 @@ import Control.Monad.IO.Class import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) -share - [ mkPersistWith sqlSettings [entityDef (Proxy @User)] - ] [persistLowerCase| +mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| Profile Id UserId From 1ae33b8d96f08f0ea2782e8bf1d4d44adc05a223 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 17 Jun 2021 16:09:01 -0600 Subject: [PATCH 4/6] chagnelog, version bump --- persistent/ChangeLog.md | 5 +++++ persistent/persistent.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index af77be8c2..33a8ca8f9 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## 2.13.0.3 + +* [#1287](https://github.com/yesodweb/persistent/pull/1287) + * Fix the duplicate entity check for transitive dependencies + ## 2.13.0.2 * [#1265](https://github.com/yesodweb/persistent/pull/1265) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index dd3ab9bbb..355086401 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.13.0.2 +version: 2.13.0.3 license: MIT license-file: LICENSE author: Michael Snoyman From 207bb731f305fc9a707c41baeae42a0bda51979b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 18 Jun 2021 10:47:06 -0600 Subject: [PATCH 5/6] fix type name construction --- persistent/ChangeLog.md | 5 +- persistent/Database/Persist/TH.hs | 145 ++++++++++++++++-- .../Database/Persist/TH/PersistWith/Model.hs | 2 +- .../Database/Persist/TH/PersistWithSpec.hs | 6 +- .../TH/SharedPrimaryKeyImportedSpec.hs | 8 +- 5 files changed, 141 insertions(+), 25 deletions(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 33a8ca8f9..19343e181 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -3,7 +3,10 @@ ## 2.13.0.3 * [#1287](https://github.com/yesodweb/persistent/pull/1287) - * Fix the duplicate entity check for transitive dependencies + * Fix the duplicate entity check for transitive dependencies. + * Fixes an issue where generating code would refer to the `ModelName` when + making a reference to another table when the explicit code only refers to + `ModelNameId`. ## 2.13.0.2 diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index f4ac92b56..f6d2d1271 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -771,10 +771,12 @@ mkPersistWith mps preexistingEntities ents' = do $ predefs entityMap = constructEntityMap allEnts + preexistingSet = + Set.fromList $ map getEntityHaskellName preexistingEntities newEnts = - Set.toList $ - Set.fromList allEnts - Set.\\ Set.fromList (map unbindEntityDef preexistingEntities) + filter + (\e -> getUnboundEntityNameHS e `Set.notMember` preexistingSet) + allEnts ents <- filterM shouldGenerateCode newEnts requireExtensions [ [TypeFamilies], [GADTs, ExistentialQuantification] @@ -1039,9 +1041,15 @@ dataTypeDec mps entityMap entDef = do cols :: [VarBangType] cols = do fieldDef <- getUnboundFieldDefs entDef - let recordName = fieldDefToRecordName mps entDef fieldDef - strictness = if unboundFieldStrict fieldDef then isStrict else notStrict - fieldIdType = maybeIdType mps entityMap fieldDef Nothing Nothing + let + recordName = + fieldDefToRecordName mps entDef fieldDef + strictness = + if unboundFieldStrict fieldDef + then isStrict + else notStrict + fieldIdType = + maybeIdType mps entityMap fieldDef Nothing Nothing pure (recordName, strictness, fieldIdType) constrs @@ -1099,6 +1107,45 @@ mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) = , "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'. +-- It takes care to respect the 'mpsGeneric' setting to render an Id faithfully, +-- and it also ensures that the generated Haskell type is 'Maybe' if the +-- database column has that attribute. +-- +-- For a database schema with @'mpsGeneric' = False@, this is simple - it uses +-- the @ModelNameId@ type directly. This resolves just fine. +-- +-- If 'mpsGeneric' is @True@, then we have to do something a bit more +-- complicated. We can't refer to a @ModelNameId@ directly, because that @Id@ +-- alias hides the backend type variable. Instead, we need to refer to: +-- +-- > Key (ModelNameGeneric backend) +-- +-- This means that the client code will need both the term @ModelNameId@ in +-- scope, as well as the @ModelNameGeneric@ constructor, despite the fact that +-- the @ModelNameId@ is the only term explicitly used (and imported). +-- +-- However, we're not guaranteed to have @ModelName@ in scope - we've only +-- referenced @ModelNameId@ in code, and so code generation *should* work even +-- without this. Consider an explicit-style import: +-- +-- @ +-- import Model.Foo (FooId) +-- +-- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| +-- Bar +-- foo FooId +-- |] +-- @ +-- +-- This looks like it ought to work, but it would fail with @mpsGeneric@ being +-- enabled. One hacky work-around is to perform a @'lookupTypeName' :: String -> +-- Q (Maybe Name)@ on the @"ModelNameId"@ type string. If the @Id@ is +-- a reference in the 'EntityMap' and @lookupTypeName@ returns @'Just' name@, +-- then that 'Name' contains the fully qualified information needed to use the +-- 'Name' without importing it at the client-site. Then we can perform a bit of +-- surgery on the 'Name' to strip the @Id@ suffix, turn it into a 'Type', and +-- apply the 'Key' constructor. maybeIdType :: MkPersistSettings -> EntityMap @@ -1115,25 +1162,90 @@ maybeIdType mps entityMap fieldDef mbackend mnull = True _ -> maybeNullable fieldDef - idType = fromMaybe (ftToType $ unboundFieldType fieldDef) $ do - typ <- extractForeignRef entityMap fieldDef - pure $ - ConT ''Key - `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) + idType = + fromMaybe (ftToType $ unboundFieldType fieldDef) $ do + typ <- extractForeignRef entityMap fieldDef + guard ((mpsGeneric mps)) + pure $ + ConT ''Key + `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) + + -- TODO: if we keep mpsGeneric, this needs to check 'mpsGeneric' and then + -- append Generic to the model name, probably + _removeIdFromTypeSuffix :: Name -> Type + _removeIdFromTypeSuffix oldName@(Name (OccName nm) nameFlavor) = + case stripSuffix "Id" (T.pack nm) of + Nothing -> + ConT oldName + Just name -> + ConT ''Key + `AppT` do + ConT $ Name (OccName (T.unpack name)) nameFlavor + + -- | TODO: if we keep mpsGeneric, let's incorporate this behavior here, so + -- end users don't need to import the constructor type as well as the id type + -- + -- Returns 'Nothing' if the given text does not appear to be a table reference. + -- In that case, do the usual thing for generating a type name. + -- + -- Returns a @Just typ@ if the text appears to be a model name, and if the + -- @ModelId@ type is in scope. The 'Type' is a fully qualified reference to + -- @'Key' ModelName@ such that end users won't have to import it directly. + _lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type) + _lookupReferencedTable em fieldTypeText = do + let + mmodelIdString = do + fieldTypeNoId <- stripSuffix "Id" fieldTypeText + _ <- M.lookup (EntityNameHS fieldTypeNoId) em + pure (T.unpack fieldTypeText) + case mmodelIdString of + Nothing -> + pure Nothing + Just modelIdString -> do + mIdName <- lookupTypeName modelIdString + pure $ fmap _removeIdFromTypeSuffix mIdName + + _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String + _fieldNameEndsWithId ufd = go (unboundFieldType ufd) + where + go = \case + FTTypeCon mmodule name -> do + a <- stripSuffix "Id" name + pure $ + T.unpack $ mconcat + [ case mmodule of + Nothing -> + "" + Just m -> + mconcat [m, "."] + , a + , "Id" + ] + _ -> + Nothing backendDataType :: MkPersistSettings -> Type backendDataType mps | mpsGeneric mps = backendT | otherwise = mpsBackend mps +-- | TODO: +-- +-- if we keep mpsGeneric +-- then +-- let's make this fully qualify the generic name +-- else +-- let's delete it genericDataType :: MkPersistSettings -> EntityNameHS -> Type -- ^ backend -> Type genericDataType mps name backend - | mpsGeneric mps = ConT (mkEntityNameHSGenericName name) `AppT` backend - | otherwise = ConT $ mkEntityNameHSName name + | mpsGeneric mps = + ConT (mkEntityNameHSGenericName name) `AppT` backend + | otherwise = + ConT $ mkEntityNameHSName name degen :: [Clause] -> [Clause] degen [] = @@ -2431,8 +2543,10 @@ mkField mps entityMap et fieldDef = do con = ForallC [] - [mkEqualP (VarT $ mkName "typ") $ maybeIdType mps entityMap fieldDef Nothing Nothing] + [mkEqualP (VarT $ mkName "typ") fieldT] $ NormalC name [] + fieldT = + maybeIdType mps entityMap fieldDef Nothing Nothing bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef) let cla = normalClause [ConP name []] @@ -2644,7 +2758,7 @@ mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do lowerFirstIfId xs = xs fieldTypeT - | fieldHaskellName == FieldNameHS "Id" = + | fieldHaskellName == FieldNameHS "Id" = do conT ''Key `appT` recordNameT | otherwise = pure $ maybeIdType mps entityMap fieldDef Nothing Nothing @@ -2681,7 +2795,6 @@ mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do symbolToField = $(entityFieldConstr) |] - -- | Pass in a list of lists of extensions, where any of the given -- extensions will satisfy it. For example, you might need either GADTs or -- ExistentialQuantification, so you'd write: diff --git a/persistent/test/Database/Persist/TH/PersistWith/Model.hs b/persistent/test/Database/Persist/TH/PersistWith/Model.hs index 2c730bec8..c8270f649 100644 --- a/persistent/test/Database/Persist/TH/PersistWith/Model.hs +++ b/persistent/test/Database/Persist/TH/PersistWith/Model.hs @@ -18,7 +18,7 @@ import TemplateTestImports import Database.Persist.TH.PersistWith.Model2 -mkPersist sqlSettings [persistLowerCase| +mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| IceCream flavor FlavorId diff --git a/persistent/test/Database/Persist/TH/PersistWithSpec.hs b/persistent/test/Database/Persist/TH/PersistWithSpec.hs index 4ddc94ac0..b73f97549 100644 --- a/persistent/test/Database/Persist/TH/PersistWithSpec.hs +++ b/persistent/test/Database/Persist/TH/PersistWithSpec.hs @@ -15,10 +15,11 @@ module Database.Persist.TH.PersistWithSpec where import TemplateTestImports -import Database.Persist.TH.PersistWith.Model +import Database.Persist.TH.PersistWith.Model (IceCreamId) import Data.List (find) +import Language.Haskell.TH as TH -mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| +mkPersistWith sqlSettings { mpsGeneric = False } $(discoverEntities) [persistLowerCase| BestTopping iceCream IceCreamId @@ -36,4 +37,3 @@ spec = describe "mkPersistWith" $ do fieldReference iceCreamField `shouldBe` ForeignRef (EntityNameHS "IceCream") - diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs index bf1a455c2..7a1a83dd5 100644 --- a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs @@ -28,7 +28,7 @@ import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| -Profile +ProfileX Id UserId email String @@ -44,7 +44,7 @@ spec = describe "Shared Primary Keys Imported" $ do it "should match underlying key" $ do sqlType (Proxy @UserId) `shouldBe` - sqlType (Proxy @ProfileId) + sqlType (Proxy @ProfileXId) describe "getEntityId FieldDef" $ do it "should match underlying primary key" $ do @@ -58,7 +58,7 @@ spec = describe "Shared Primary Keys Imported" $ do SqlOther "Composite Key" getSqlType (Proxy @User) `shouldBe` - getSqlType (Proxy @Profile) + getSqlType (Proxy @ProfileX) describe "foreign reference should work" $ do @@ -66,7 +66,7 @@ spec = describe "Shared Primary Keys Imported" $ do pendingWith "issue #1289" let Just fd = - getEntityIdField (entityDef (Proxy @Profile)) + getEntityIdField (entityDef (Proxy @ProfileX)) fieldReference fd `shouldBe` ForeignRef (EntityNameHS "User") From c74bb1d91bba5562a21cfdbdaab75286466e759c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 18 Jun 2021 11:00:23 -0600 Subject: [PATCH 6/6] ok --- persistent/Database/Persist/TH.hs | 2 +- persistent/test/Database/Persist/TH/PersistWithSpec.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index f6d2d1271..10147028e 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -2758,7 +2758,7 @@ mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do lowerFirstIfId xs = xs fieldTypeT - | fieldHaskellName == FieldNameHS "Id" = do + | fieldHaskellName == FieldNameHS "Id" = conT ''Key `appT` recordNameT | otherwise = pure $ maybeIdType mps entityMap fieldDef Nothing Nothing diff --git a/persistent/test/Database/Persist/TH/PersistWithSpec.hs b/persistent/test/Database/Persist/TH/PersistWithSpec.hs index b73f97549..f69690394 100644 --- a/persistent/test/Database/Persist/TH/PersistWithSpec.hs +++ b/persistent/test/Database/Persist/TH/PersistWithSpec.hs @@ -19,7 +19,7 @@ import Database.Persist.TH.PersistWith.Model (IceCreamId) import Data.List (find) import Language.Haskell.TH as TH -mkPersistWith sqlSettings { mpsGeneric = False } $(discoverEntities) [persistLowerCase| +mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| BestTopping iceCream IceCreamId