include entity and foreign field schema name parsing

persistent/Database/Persist/Quasi.hs

@@ -186,13 +186,23 @@ User sql=big_user_table
 This will alter the generated SQL to be:
 
 @
-CREATE TABEL big_user_table (
+CREATE TABLE big_user_table (
     id      SERIAL PRIMARY KEY,
     name    VARCHAR,
     age     INT
 );
 @
 
+= Table Schema
+
+You can use a @schema=some_schema@ annotation to specify the table's schema name.
+This can be placed before or after the entity's @sql=custom@ annotation, if it has one.
+
+@
+Foo schema=bar
+    baz        Int
+@
+
 = Customizing Types/Tables
 
 == JSON instances

persistent/Database/Persist/Quasi/Internal.hs

@@ -310,6 +310,7 @@ parseLines ps = do
 data ParsedEntityDef = ParsedEntityDef
     { parsedEntityDefComments :: [Text]
     , parsedEntityDefEntityName :: EntityNameHS
+    , parsedEntityDefSchemaName :: Maybe SchemaNameDB
     , parsedEntityDefIsSum :: Bool
     , parsedEntityDefEntityAttributes :: [Attr]
     , parsedEntityDefFieldAttributes :: [[Token]]
@@ -329,6 +330,7 @@ toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
 toParsedEntityDef lwc = ParsedEntityDef
     { parsedEntityDefComments = lwcComments lwc
     , parsedEntityDefEntityName = entNameHS
+    , parsedEntityDefSchemaName = schemaName
     , parsedEntityDefIsSum = isSum
     , parsedEntityDefEntityAttributes = entAttribs
     , parsedEntityDefFieldAttributes = attribs
@@ -349,6 +351,9 @@ toParsedEntityDef lwc = ParsedEntityDef
     (attribs, extras) =
         parseEntityFields fieldLines
 
+    schemaName =
+      fmap SchemaNameDB $ listToMaybe $ mapMaybe (T.stripPrefix "schema=") entAttribs
+
 isDocComment :: Token -> Maybe Text
 isDocComment tok =
     case tok of
@@ -712,8 +717,7 @@ mkUnboundEntityDef ps parsedEntDef =
                     case parsedEntityDefComments parsedEntDef of
                         [] -> Nothing
                         comments -> Just (T.unlines comments)
-                , -- TODO: start parsing the schema attribute and write it here.
-                  entitySchema = Nothing
+                , entitySchema = parsedEntityDefSchemaName parsedEntDef
                 }
         }
   where
@@ -1392,14 +1396,9 @@ takeForeign ps entityName = takeRefTable
                                 EntityNameHS refTableName
                             , foreignRefTableDBName =
                                 EntityNameDB $ psToDBName ps refTableName
-                            , -- TODO: The existing foreign key syntax for
-                              -- UnboundForeignDef is not sufficiently rich to
-                              -- allow specifying the schema of the foreign
-                              -- relation. We need to add the ability to parse
-                              -- schema=foo directives inline for foreign keys
-                              -- and insert those values here.
-                              foreignRefSchemaDBName =
+                            , foreignRefSchemaDBName =
                                 Nothing
+                            -- ^ This will be determined in the TH phase ('fixForeignRefSchemaDBName').
                             , foreignConstraintNameHaskell =
                                 constraintName
                             , foreignConstraintNameDBName =

persistent/Database/Persist/TH.hs

@@ -331,11 +331,15 @@ liftAndFixKeys mps emEntities entityMap unboundEnt =
                     $(lift fixForeignNullable)
                 , foreignRefTableDBName =
                     $(lift fixForeignRefTableDBName)
+                , foreignRefSchemaDBName =
+                    $(lift fixForeignRefSchemaDBName)
                 }
             |]
           where
             fixForeignRefTableDBName =
                 getEntityDBName (unboundEntityDef parentDef)
+            fixForeignRefSchemaDBName = 
+                getEntitySchema (unboundEntityDef parentDef)
             foreignFieldNames =
                 case unboundForeignFields of
                     FieldListImpliedId ffns ->

persistent/test/Database/Persist/QuasiSpec.hs

@@ -332,6 +332,7 @@ Notification
                 [ ForeignDef
                     { foreignRefTableHaskell = EntityNameHS "User"
                     , foreignRefTableDBName = EntityNameDB "user"
+                    , foreignRefSchemaDBName = Nothing
                     , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user"
                     , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user"
                     , foreignFieldCascade = FieldCascade Nothing Nothing

persistent/test/Database/Persist/TH/ForeignRefSpec.hs

@@ -49,6 +49,7 @@ mkPersist sqlSettings [persistLowerCase|
 
 HasCustomName sql=custom_name
     name Text
+    Primary name
 
 ForeignTarget
     name Text
@@ -79,7 +80,7 @@ ChildImplicit
     name Text
     parent ParentImplicitId OnDeleteCascade OnUpdateCascade
 
-ParentExplicit
+ParentExplicit schema=adult
     name Text
     Primary name
 
@@ -176,3 +177,12 @@ spec = describe "ForeignRefSpec" $ do
                             , "got: "
                             , show as
                             ]
+
+    describe "Foreign Schema Name" $ do
+        let
+            [childForeignDef] =
+                entityForeigns $ entityDef $ Proxy @ChildExplicit
+        it "should have the correct schema name" $ do
+            (foreignRefSchemaDBName childForeignDef)
+                `shouldBe`
+                    (Just $ SchemaNameDB "adult")

persistent/test/Database/Persist/THSpec.hs

@@ -71,14 +71,13 @@ import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpe
 import qualified Database.Persist.TH.SumSpec as SumSpec
 import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec
 import qualified Database.Persist.TH.TypeLitFieldDefsSpec as TypeLitFieldDefsSpec
-
 -- test to ensure we can have types ending in Id that don't trash the TH
 -- machinery
 type TextId = Text
 
 share [mkPersistWith  sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase|
 
-Person json
+Person json schema=some_schema
     name Text
     age Int Maybe
     foo Foo
@@ -507,6 +506,13 @@ spec = describe "THSpec" $ do
         it "has a good safe to insert class instance" $ do
             let proxy = Proxy :: SafeToInsert CustomIdName => Proxy CustomIdName
             proxy `shouldBe` Proxy
+    describe "Entity Schema" $ do
+        let personDef =
+                entityDef (Proxy :: Proxy Person)
+        it "reads the entity schema" $ do
+            (entitySchema personDef)
+                `shouldBe`
+                    (Just $ SchemaNameDB "some_schema")
 
 (&) :: a -> (a -> b) -> b
 x & f = f x