discoverEntities

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")

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")

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.
 * [#1250](https://github.com/yesodweb/persistent/pull/1250)
     * The `mpsGeneric` function has been deprecated. If you need this
       functionality, please comment with your needs on the GitHub issue tracker.

persistent/Database/Persist/TH.hs

@@ -47,6 +47,7 @@ module Database.Persist.TH
       -- * Various other TH functions
     , mkMigrate
     , migrateModels
+    , discoverEntities
     , mkSave
     , mkDeleteCascade
     , mkEntityDefList
@@ -2163,3 +2164,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 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.
+--
+-- @
+-- -- 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 $(discoverEntities) [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
+                _ ->
+                    Nothing
+        stripPersistEntity typ =
+            case typ of
+                AppT (ConT tyName) t | tyName == ''PersistEntity ->
+                    Just t
+                _ ->
+                    Nothing
+
+    fmap ListE $
+        forM types $ \typ -> do
+            [e| entityDef (Proxy :: Proxy $(pure typ)) |]

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

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
+            ]

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))

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)