Fix duplicate entity checks (#1287)

parsonsmatt · web-flow · commit 6de3ffe57091 · 2021-06-18T16:03:22.000-06:00
* Fix duplicate entity checks

* Fix the issue

* nice

* chagnelog, version bump

* fix type name construction

* ok
diff --git 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
@@ -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
@@ -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
@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.13.0.2
+version:         2.13.0.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -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
@@ -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
@@ -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
diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs
diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs
