persistent 2.13.0.2 → 2.13.0.3
raw patch · 9 files changed
+270/−39 lines, 9 files
Files
- ChangeLog.md +19/−11
- Database/Persist/Quasi/Internal.hs +8/−8
- Database/Persist/TH.hs +130/−15
- persistent.cabal +4/−1
- test/Database/Persist/TH/PersistWith/Model.hs +26/−0
- test/Database/Persist/TH/PersistWith/Model2.hs +24/−0
- test/Database/Persist/TH/PersistWithSpec.hs +39/−0
- test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +17/−4
- test/Database/Persist/THSpec.hs +3/−0
ChangeLog.md view
@@ -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)@@ -83,17 +91,6 @@ * [#1255](https://github.com/yesodweb/persistent/pull/1255) * `mkPersist` now checks to see if an instance already exists for `PersistEntity` for the inputs.--## 2.12.1.2--* [#1258](https://github.com/yesodweb/persistent/pull/1258)- * Support promoted types in Quasi Quoter-* [#1243](https://github.com/yesodweb/persistent/pull/1243)- * Assorted cleanup of TH module-* [#1242](https://github.com/yesodweb/persistent/pull/1242)- * Refactor setEmbedField to use do notation-* [#1237](https://github.com/yesodweb/persistent/pull/1237)- * Remove nonEmptyOrFail function from recent tests * [#1256](https://github.com/yesodweb/persistent/pull/1256) * The QuasiQuoter has been refactored and improved. * You can now use `mkPersistWith` to pass in a list of pre-existing@@ -107,6 +104,17 @@ on fields. * You can use `Key Foo` and `FooId` interchangeably in fields. * Support for GHC < 8.4 dropped.++## 2.12.1.2++* [#1258](https://github.com/yesodweb/persistent/pull/1258)+ * Support promoted types in Quasi Quoter+* [#1243](https://github.com/yesodweb/persistent/pull/1243)+ * Assorted cleanup of TH module+* [#1242](https://github.com/yesodweb/persistent/pull/1242)+ * Refactor setEmbedField to use do notation+* [#1237](https://github.com/yesodweb/persistent/pull/1237)+ * Remove nonEmptyOrFail function from recent tests ## 2.12.1.1
Database/Persist/Quasi/Internal.hs view
@@ -416,7 +416,7 @@ -- -- @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 @@ -- -- @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 @@ -- 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 @@ , 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 @@ -- -- @since 2.13.0.0 }- deriving (Show, Lift)+ deriving (Eq, Ord, Show, Lift) takeComposite :: [FieldNameHS]@@ -1130,7 +1130,7 @@ -- -- @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 @@ -- @ -- -- @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 @@ -- -- @since 2.13.0.0 }- deriving (Eq, Show, Lift)+ deriving (Eq, Ord, Show, Lift) unbindForeignDef :: ForeignDef -> UnboundForeignDef unbindForeignDef fd =
Database/Persist/TH.hs view
@@ -237,8 +237,6 @@ (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 @@ $ 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 @@ 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 @@ , "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 @@ 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 @@ 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 []]@@ -2678,7 +2794,6 @@ instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where 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
persistent.cabal view
@@ -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 @@ 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
+ test/Database/Persist/TH/PersistWith/Model.hs view
@@ -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++|]
+ test/Database/Persist/TH/PersistWith/Model2.hs view
@@ -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++|]
+ test/Database/Persist/TH/PersistWithSpec.hs view
@@ -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")
@@ -21,12 +21,14 @@ 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 @@ 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 @@ 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")
test/Database/Persist/THSpec.hs view
@@ -45,6 +45,8 @@ 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 @@ spec :: Spec spec = describe "THSpec" $ do+ PersistWithSpec.spec KindEntitiesSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec