From 4a89d89061a895c3df9fdd13c910940e5abc829b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 26 Apr 2021 14:04:34 -0600 Subject: [PATCH 1/5] discover entities --- persistent/Database/Persist/TH.hs | 78 +++++++++++++++++++ persistent/persistent.cabal | 1 + .../Persist/TH/DiscoverEntitiesSpec.hs | 60 ++++++++++++++ persistent/test/Database/Persist/THSpec.hs | 34 ++++---- persistent/test/TemplateTestImports.hs | 3 + 5 files changed, 161 insertions(+), 15 deletions(-) create mode 100644 persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 8c10c27c8..8306cf0b6 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -47,6 +47,7 @@ module Database.Persist.TH -- * Various other TH functions , mkMigrate , migrateModels + , discoverEntities , mkSave , mkDeleteCascade , mkEntityDefList @@ -2160,3 +2161,80 @@ filterConName' mps entity field = mkName $ T.unpack name modifiedName = mpsConstraintLabelModifier mps entityName fieldName 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 +-- [ mkPersist sqlSettings . mappend $(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 taht 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. +-- mkPersist sqlSettings . mappend $(disoverEntities) [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")] + let + types = + mapMaybe getDecType instances + getDecType dec = + case dec of + InstanceD _moverlap _cxt typ _decs -> + stripPersistEntity typ + _ -> + error $ show dec + stripPersistEntity typ = + case typ of + AppT (ConT tyName) t | tyName == ''PersistEntity -> + Just t + _ -> + error $ show typ + + fmap ListE $ + forM types $ \typ -> do + [e| entityDef (Proxy :: Proxy $(pure typ)) |] diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 35fbe6d42..01086c08f 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -164,6 +164,7 @@ test-suite test Database.Persist.TH.SharedPrimaryKeyImportedSpec Database.Persist.TH.OverloadedLabelSpec Database.Persist.TH.ImplicitIdColSpec + Database.Persist.TH.DiscoverEntitiesSpec default-language: Haskell2010 source-repository head diff --git a/persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs b/persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs new file mode 100644 index 000000000..9e030821d --- /dev/null +++ b/persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs @@ -0,0 +1,60 @@ +{-# 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.DiscoverEntitiesSpec where + +import TemplateTestImports + +import Data.Aeson + +import Data.Text (Text) + +import Language.Haskell.TH.Syntax + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +mkPersist sqlSettings [persistLowerCase| + +User + name String + age Int + +Dog + user UserId + name String + +Cat + enemy DogId + name String + +|] + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +pure [] + +spec :: Spec +spec = describe "DiscoverEntitiesSpec" $ do + let entities = $(discoverEntities) + it "should have all three entities" $ do + entities `shouldMatchList` + [ entityDef $ Proxy @User + , entityDef $ Proxy @Dog + , entityDef $ Proxy @Cat + ] diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 89fe8e805..eba70aca8 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE TypeApplications, DeriveGeneric, RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# language DataKinds #-} -- -- DeriveAnyClass is not actually used by persistent-template -- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving @@ -21,32 +23,33 @@ module Database.Persist.THSpec where -import Data.Int -import Data.Proxy -import Control.Applicative (Const (..)) +import Control.Applicative (Const(..)) import Data.Aeson import Data.ByteString.Lazy.Char8 () -import Data.Functor.Identity (Identity (..)) +import Data.Coerce +import Data.Functor.Identity (Identity(..)) +import Data.Int +import qualified Data.List as List +import Data.Proxy import Data.Text (Text, pack) +import GHC.Generics (Generic) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen) -import GHC.Generics (Generic) -import qualified Data.List as List -import Data.Coerce import Database.Persist +import Database.Persist.EntityDef.Internal import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports -import Database.Persist.EntityDef.Internal -import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec -import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec -import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec +import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec +import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec +import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec +import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| @@ -141,6 +144,7 @@ spec = do SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec ImplicitIdColSpec.spec + DiscoverEntitiesSpec.spec describe "TestDefaultKeyCol" $ do let FieldDef{..} = entityId (entityDef (Proxy @TestDefaultKeyCol)) diff --git a/persistent/test/TemplateTestImports.hs b/persistent/test/TemplateTestImports.hs index 820c3aedf..5f4886f7e 100644 --- a/persistent/test/TemplateTestImports.hs +++ b/persistent/test/TemplateTestImports.hs @@ -16,6 +16,9 @@ import Database.Persist.TH as X import Test.Hspec as X import Data.Proxy as X import Data.Text as X (Text) +import Data.Maybe +import Control.Monad +import Language.Haskell.TH.Syntax data Foo = Bar | Baz deriving (Show, Eq) From 6517716ed3efb4ff4929764e47ae381e6dc6ed5f Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 26 Apr 2021 14:05:51 -0600 Subject: [PATCH 2/5] remove fdescribe --- persistent-mysql/test/ImplicitUuidSpec.hs | 2 +- persistent-postgresql/test/ImplicitUuidSpec.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent-mysql/test/ImplicitUuidSpec.hs b/persistent-mysql/test/ImplicitUuidSpec.hs index bdc1e4f14..448173a3b 100644 --- a/persistent-mysql/test/ImplicitUuidSpec.hs +++ b/persistent-mysql/test/ImplicitUuidSpec.hs @@ -51,7 +51,7 @@ pass :: IO () pass = pure () spec :: Spec -spec = fdescribe "ImplicitUuidSpec" $ before_ wipe $ do +spec = describe "ImplicitUuidSpec" $ before_ wipe $ do describe "WithDefUuidKey" $ do it "works on UUIDs" $ do let withDefUuidKey = WithDefUuidKey (UUID "Hello") diff --git a/persistent-postgresql/test/ImplicitUuidSpec.hs b/persistent-postgresql/test/ImplicitUuidSpec.hs index 0520d516d..4f08b3d5e 100644 --- a/persistent-postgresql/test/ImplicitUuidSpec.hs +++ b/persistent-postgresql/test/ImplicitUuidSpec.hs @@ -52,7 +52,7 @@ pass :: IO () pass = pure () spec :: Spec -spec = fdescribe "ImplicitUuidSpec" $ before_ wipe $ do +spec = describe "ImplicitUuidSpec" $ before_ wipe $ do describe "WithDefUuidKey" $ do it "works on UUIDs" $ do let withDefUuidKey = WithDefUuidKey (UUID "Hello") From 880ac46fe82810c58e5d87adbf47653a1553514d Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 26 Apr 2021 14:09:30 -0600 Subject: [PATCH 3/5] changelog --- persistent/ChangeLog.md | 3 +++ persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 97f8dc9d7..b4f75bc67 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -49,6 +49,9 @@ * Add the `runSqlCommand` function for running arbitrary SQL during migrations. * Add `migrateModels` function for a TH-free migration facility. +* [#1253](https://github.com/yesodweb/persistent/pull/1253) + * Add `discoverEntities` to discover instances of the class and return their + entity definitions. ## 2.12.1.1 diff --git a/persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs b/persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs index 9e030821d..d8eef9b3e 100644 --- a/persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs +++ b/persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs @@ -47,7 +47,7 @@ pass = pure () asIO :: IO a -> IO a asIO = id -pure [] +$(pure []) spec :: Spec spec = describe "DiscoverEntitiesSpec" $ do From a717df7bc6aae42b89e5572ca497bd5141fc753d Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 26 Apr 2021 14:11:21 -0600 Subject: [PATCH 4/5] yupo --- persistent/Database/Persist/TH.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 8306cf0b6..c6593b516 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -2185,7 +2185,7 @@ filterConName' mps entity field = mkName $ T.unpack name -- @ -- -- Note that there is some odd behavior with Template Haskell and splicing --- groups. If you call 'discoverEntities' in the same module taht defines +-- 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. -- @@ -2195,7 +2195,7 @@ filterConName' mps entity field = mkName $ T.unpack name -- import Bar -- -- -- Since Foo and Bar are both imported, discoverEntities can find them here. --- mkPersist sqlSettings . mappend $(disoverEntities) [persistLowerCase| +-- mkPersist sqlSettings . mappend $(discoverEntities) [persistLowerCase| -- User -- name Text -- age Int From dd32e50143b93d4e79c15f0e62aac86eb2ada6d3 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 26 Apr 2021 14:11:45 -0600 Subject: [PATCH 5/5] remove error --- persistent/Database/Persist/TH.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index c6593b516..0d631add9 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -2227,13 +2227,13 @@ discoverEntities = do InstanceD _moverlap _cxt typ _decs -> stripPersistEntity typ _ -> - error $ show dec + Nothing stripPersistEntity typ = case typ of AppT (ConT tyName) t | tyName == ''PersistEntity -> Just t _ -> - error $ show typ + Nothing fmap ListE $ forM types $ \typ -> do