diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 451f92229..e41292d6c 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/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 diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 9e418c4f3..330645202 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/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 = diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 0a2df94cc..009f0b94b 100644 --- a/persistent/Database/Persist/TH.hs +++ b/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 -> diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 02356ee9f..6d08fe27e 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/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 diff --git a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs index b4e694e57..0e876076e 100644 --- a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs +++ b/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") diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index cfba70c6b..1397f8dbe 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/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