diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index af77be8c2..19343e181 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for persistent +## 2.13.0.3 + +* [#1287](https://github.com/yesodweb/persistent/pull/1287) + * 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 * [#1265](https://github.com/yesodweb/persistent/pull/1265) 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..10147028e 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,13 @@ mkPersistWith mps preexistingEntities ents' = do $ predefs entityMap = constructEntityMap allEnts - ents <- filterM shouldGenerateCode allEnts + preexistingSet = + Set.fromList $ map getEntityHaskellName preexistingEntities + newEnts = + filter + (\e -> getUnboundEntityNameHS e `Set.notMember` preexistingSet) + allEnts + ents <- filterM shouldGenerateCode newEnts requireExtensions [ [TypeFamilies], [GADTs, ExistentialQuantification] , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] @@ -1037,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 @@ -1097,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 @@ -1113,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 [] = @@ -2429,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 []] @@ -2679,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/persistent.cabal b/persistent/persistent.cabal index b3a95981d..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 @@ -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..c8270f649 --- /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 + +mkPersistWith sqlSettings $(discoverEntities) [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..f69690394 --- /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 (IceCreamId) +import Data.List (find) +import Language.Haskell.TH as TH + +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..7a1a83dd5 100644 --- a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs @@ -21,12 +21,14 @@ 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| +mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| -Profile +ProfileX Id UserId email String @@ -42,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 @@ -56,4 +58,15 @@ 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 + it "should have a foreign reference" $ do + pendingWith "issue #1289" + let + Just fd = + getEntityIdField (entityDef (Proxy @ProfileX)) + 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