From 884ca0810bfe1d10883c3a564a8dbf0d253e8599 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 21:26:46 +0100 Subject: [PATCH 01/12] Implement config for customising the FK name --- persistent/Database/Persist/Quasi.hs | 7 ++++++- persistent/test/main.hs | 31 ++++++++++++++++++++++------ 2 files changed, 31 insertions(+), 7 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 9a6a88672..4664eb47c 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -504,6 +504,10 @@ parseFieldType t0 = data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) + , psToFKName :: !(Text -> Text) + -- ^ Configuration. Default value: @identity@ + -- + -- @since 2.12.1.2 , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- @@ -519,6 +523,7 @@ data PersistSettings = PersistSettings defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id + , psToFKName = id , psStrictFields = True , psIdName = "id" } @@ -1124,7 +1129,7 @@ takeForeign ps tableName _defs = takeRefTable , foreignConstraintNameHaskell = ConstraintNameHS n , foreignConstraintNameDBName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` n) + ConstraintNameDB $ psToDBName ps (tableName `T.append` (psToFKName ps n)) , foreignFieldCascade = FieldCascade { fcOnDelete = onDelete , fcOnUpdate = onUpdate diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 5cb405888..b7ac175ba 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -3,23 +3,23 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck import qualified Data.Char as Char -import qualified Data.Text as T import Data.List import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map +import qualified Data.Text as T +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck #if !MIN_VERSION_base(4,11,0) -- This can be removed when GHC < 8.2.2 isn't supported anymore import Data.Semigroup ((<>)) #endif -import Data.Time -import Text.Shakespeare.Text import Data.Aeson import qualified Data.ByteString.Char8 as BS8 +import Data.Time +import Text.Shakespeare.Text import Database.Persist.Class.PersistField import Database.Persist.Quasi @@ -358,6 +358,25 @@ Notification entityComments car `shouldBe` Just "This is a Car\n" entityComments vehicle `shouldBe` Nothing + it "should parse the `entityForeigns` field" $ do + let [user, notification] = parse (lowerCaseSettings { psToFKName = (<>) "_" }) [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + + Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond +|] + let [notificationForeignDef] = entityForeigns notification + foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "notification_fk_noti_user" + describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") From 8488babc112857890d542caca6c7309ff593a052 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 21:34:59 +0100 Subject: [PATCH 02/12] Update changelog --- persistent/ChangeLog.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 951eaf947..205e6508b 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## 2.12.1.2 + +* [1244](https://github.com/yesodweb/persistent/pull/1244) + * Implement config for customising the FK name + ## 2.12.1.1 * [#1231](https://github.com/yesodweb/persistent/pull/1231) From ca6724903c07c2dd82a0795f468afba26af2bf30 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 21:36:19 +0100 Subject: [PATCH 03/12] Tweak test description --- persistent/test/main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/test/main.hs b/persistent/test/main.hs index b7ac175ba..3161ee433 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -358,7 +358,7 @@ Notification entityComments car `shouldBe` Just "This is a Car\n" entityComments vehicle `shouldBe` Nothing - it "should parse the `entityForeigns` field" $ do + it "should allow you to modify the FK name via provided function" $ do let [user, notification] = parse (lowerCaseSettings { psToFKName = (<>) "_" }) [st| User name Text From 8a4c5169f9ccd58eee2e79139ba7545749cb1735 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 21:48:57 +0100 Subject: [PATCH 04/12] Tweaks/better use of types --- persistent/Database/Persist/Quasi.hs | 23 +++++++++++++++++++---- persistent/test/main.hs | 2 +- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 4664eb47c..75a518230 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -418,6 +418,7 @@ module Database.Persist.Quasi , PersistSettings (..) , upperCaseSettings , lowerCaseSettings + , toFKNameInfixed , nullable #if TEST , Token (..) @@ -502,10 +503,14 @@ parseFieldType t0 = PSDone -> PSSuccess (front []) t -- _ -> +newtype ToFKName = ToFKName + { unToFKName :: Text -> Text -> Text + } + data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) - , psToFKName :: !(Text -> Text) - -- ^ Configuration. Default value: @identity@ + , psToFKName :: !ToFKName + -- ^ Function used to generate the FK name. Default value: @mappend@ -- -- @since 2.12.1.2 , psStrictFields :: !Bool @@ -523,7 +528,7 @@ data PersistSettings = PersistSettings defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id - , psToFKName = id + , psToFKName = ToFKName mappend , psStrictFields = True , psIdName = "id" } @@ -538,6 +543,9 @@ lowerCaseSettings = defaultPersistSettings in T.dropWhile (== '_') . T.concatMap go } +toFKNameInfixed :: Text -> ToFKName +toFKNameInfixed inf = ToFKName $ \table name -> table <> inf <> name + -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] parse ps = maybe [] (parseLines ps) . preparse @@ -1129,7 +1137,7 @@ takeForeign ps tableName _defs = takeRefTable , foreignConstraintNameHaskell = ConstraintNameHS n , foreignConstraintNameDBName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` (psToFKName ps n)) + toFKConstraintNameDB ps tableName n , foreignFieldCascade = FieldCascade { fcOnDelete = onDelete , fcOnUpdate = onUpdate @@ -1169,6 +1177,13 @@ takeForeign ps tableName _defs = takeRefTable go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs +toFKConstraintNameDB :: PersistSettings -> Text -> Text -> ConstraintNameDB +toFKConstraintNameDB ps tableName n = + ConstraintNameDB $ psToDBName ps (toFKName tableName n) + where + toFKName = + unToFKName (psToFKName ps) + data CascadePrefix = CascadeUpdate | CascadeDelete parseCascade :: [Text] -> (FieldCascade, [Text]) diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 3161ee433..8501db556 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -359,7 +359,7 @@ Notification entityComments vehicle `shouldBe` Nothing it "should allow you to modify the FK name via provided function" $ do - let [user, notification] = parse (lowerCaseSettings { psToFKName = (<>) "_" }) [st| + let [user, notification] = parse (lowerCaseSettings { psToFKName = toFKNameInfixed "_" }) [st| User name Text emailFirst Text From 030662e03713df5c36adf83f47a216333a3b4bd9 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 17:45:40 +0100 Subject: [PATCH 05/12] Review tweaks --- persistent/Database/Persist/Quasi.hs | 7 +++++-- persistent/Database/Persist/Quasi/Internal.hs | 2 +- persistent/test/main.hs | 13 ++++++++++++- 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 3a8a2a532..7e08dd677 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -413,11 +413,14 @@ Unfortunately, we can't use this to create Haddocks for you, because PersistSettings +setPsUseSnakeCaseForiegnKeys ps = ps { psToFKName = toFKNameInfixed "_" } diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 7c7bdcffc..abb3208cc 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -108,7 +108,7 @@ data PersistSettings = PersistSettings , psToFKName :: !ToFKName -- ^ Function used to generate the FK name. Default value: @mappend@ -- - -- @since 2.12.1.2 + -- @since 2.13 , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 61906ac3b..10f485403 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -22,7 +22,18 @@ import Data.Time import Text.Shakespeare.Text import Database.Persist.Class.PersistField +import Database.Persist.Quasi import Database.Persist.Quasi.Internal + ( Line(..) + , LinesWithComments(..) + , Token(..) + , associateLines + , parseFieldType + , parseLine + , preparse + , splitExtras + , takeColsEx + ) import Database.Persist.Types import qualified Database.Persist.THSpec as THSpec @@ -359,7 +370,7 @@ Notification entityComments vehicle `shouldBe` Nothing it "should allow you to modify the FK name via provided function" $ do - let [user, notification] = parse (lowerCaseSettings { psToFKName = toFKNameInfixed "_" }) [st| + let [user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) [st| User name Text emailFirst Text From 94941d7f6e541cb80ad772ac680f0bcde80f8351 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 19:44:13 +0100 Subject: [PATCH 06/12] Some initial post-review changes --- persistent/Database/Persist/Quasi/Internal.hs | 55 ++++++++++--------- persistent/Database/Persist/Types/Base.hs | 7 +++ 2 files changed, 37 insertions(+), 25 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index abb3208cc..f89790d48 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -16,6 +16,7 @@ module Database.Persist.Quasi.Internal , PersistSettings (..) , upperCaseSettings , lowerCaseSettings + , ToFKName (..) , toFKNameInfixed , nullable , Token (..) @@ -99,16 +100,12 @@ parseFieldType t0 = PSDone -> PSSuccess (front []) t -- _ -> -newtype ToFKName = ToFKName - { unToFKName :: Text -> Text -> Text - } - data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) , psToFKName :: !ToFKName -- ^ Function used to generate the FK name. Default value: @mappend@ -- - -- @since 2.13 + -- @since 2.13.0.0 , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- @@ -124,7 +121,7 @@ data PersistSettings = PersistSettings defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id - , psToFKName = ToFKName mappend + , psToFKName = ToFKName $ \(TableNameDB table) name -> table <> name , psStrictFields = True , psIdName = "id" } @@ -139,8 +136,15 @@ lowerCaseSettings = defaultPersistSettings in T.dropWhile (== '_') . T.concatMap go } +-- | A function for converting a table and column name into a constraint name. +-- +-- @since 2.13.0.0 +newtype ToFKName = ToFKName + { unToFKName :: TableNameDB -> Text -> Text + } + toFKNameInfixed :: Text -> ToFKName -toFKNameInfixed inf = ToFKName $ \table name -> table <> inf <> name +toFKNameInfixed inf = ToFKName $ \(TableNameDB table) name -> table <> inf <> name -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] @@ -431,8 +435,8 @@ mkEntityDef :: PersistSettings mkEntityDef ps name entattribs lines = UnboundEntityDef foreigns $ EntityDef - { entityHaskell = EntityNameHS name' - , entityDB = EntityNameDB $ getDbName ps name' entattribs + { entityHaskell = entName + , entityDB = EntityNameDB $ getDbName ps (unTableNameDB name') entattribs -- idField is the user-specified Id -- otherwise useAutoIdField -- but, adjust it if the user specified a Primary @@ -447,11 +451,11 @@ mkEntityDef ps name entattribs lines = , entityComments = Nothing } where - entName = EntityNameHS name' + entName = EntityNameHS (unTableNameDB name') (isSum, name') = case T.uncons name of - Just ('+', x) -> (True, x) - _ -> (False, name) + Just ('+', x) -> (True, TableNameDB x) + _ -> (False, TableNameDB name) (attribs, extras) = splitExtras lines textAttribs :: [[Text]] @@ -594,11 +598,12 @@ getDbName :: PersistSettings -> Text -> [Text] -> Text getDbName ps n [] = psToDBName ps n getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a -takeConstraint :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) +takeConstraint + :: PersistSettings + -> TableNameDB + -> [FieldDef] + -> [Text] + -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' where takeConstraint' @@ -606,12 +611,12 @@ takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) - | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint + | otherwise = (Nothing, Nothing, Just $ takeUniq ps (TableNameDB "") defs (n:rest), Nothing) -- retain compatibility with original unique constraint takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) -- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. -- need to re-work takeCols function -takeId :: PersistSettings -> Text -> [Text] -> FieldDef +takeId :: PersistSettings -> TableNameDB -> [Text] -> FieldDef takeId ps tableName (n:rest) = setFieldDef $ fromMaybe (error "takeId: impossible!") @@ -623,12 +628,12 @@ takeId ps tableName (n:rest) = addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) setFieldDef fd = fd { fieldReference = - ForeignRef (EntityNameHS tableName) $ + ForeignRef (EntityNameHS (unTableNameDB tableName)) $ if fieldType fd == FTTypeCon Nothing keyCon then defaultReferenceTypeCon else fieldType fd } - keyCon = keyConName tableName + keyCon = keyConName (unTableNameDB tableName) -- this will be ignored if there is already an existing sql= -- TODO: I think there is a ! ignore syntax that would screw this up -- setIdName = ["sql=" `mappend` psIdName ps] @@ -656,11 +661,11 @@ takeComposite fields pkcols = -- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` -- Here using sql= sets the name of the constraint. takeUniq :: PersistSettings - -> Text + -> TableNameDB -> [FieldDef] -> [Text] -> UniqueDef -takeUniq ps tableName defs (n:rest) +takeUniq ps (TableNameDB tableName) defs (n:rest) | isCapitalizedText n = UniqueDef (ConstraintNameHS n) @@ -710,7 +715,7 @@ data UnboundForeignDef = UnboundForeignDef takeForeign :: PersistSettings - -> Text + -> TableNameDB -> [FieldDef] -> [Text] -> UnboundForeignDef @@ -773,7 +778,7 @@ takeForeign ps tableName _defs = takeRefTable go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs -toFKConstraintNameDB :: PersistSettings -> Text -> Text -> ConstraintNameDB +toFKConstraintNameDB :: PersistSettings -> TableNameDB -> Text -> ConstraintNameDB toFKConstraintNameDB ps tableName n = ConstraintNameDB $ psToDBName ps (toFKName tableName n) where diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 1f6054bc2..9c1559c5d 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -453,6 +453,13 @@ data ForeignDef = ForeignDef } deriving (Show, Eq, Read, Ord, Lift) +-- | A 'TableNameDB' represents the datastore-side name that @persistent@ +-- will use for a table. +-- +-- @since 2.13.0.0 +newtype TableNameDB = TableNameDB { unTableNameDB :: Text } + deriving (Show, Eq, Read, Ord, Lift) + -- | This datatype describes how a foreign reference field cascades deletes -- or updates. -- From 6200b95bc29826fc65398cb0441e1a8e0f8dde27 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 21:31:11 +0100 Subject: [PATCH 07/12] Table name turned out to be EntityNameHS --- persistent/Database/Persist/Quasi/Internal.hs | 111 +++++++++--------- persistent/Database/Persist/Types/Base.hs | 7 -- 2 files changed, 58 insertions(+), 60 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index f89790d48..48a3b69f6 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -121,7 +121,7 @@ data PersistSettings = PersistSettings defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id - , psToFKName = ToFKName $ \(TableNameDB table) name -> table <> name + , psToFKName = ToFKName $ \(EntityNameHS entName) name -> entName <> name , psStrictFields = True , psIdName = "id" } @@ -140,11 +140,11 @@ lowerCaseSettings = defaultPersistSettings -- -- @since 2.13.0.0 newtype ToFKName = ToFKName - { unToFKName :: TableNameDB -> Text -> Text + { unToFKName :: EntityNameHS -> Text -> Text } toFKNameInfixed :: Text -> ToFKName -toFKNameInfixed inf = ToFKName $ \(TableNameDB table) name -> table <> inf <> name +toFKNameInfixed inf = ToFKName $ \(EntityNameHS entName) name -> entName <> inf <> name -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] @@ -242,13 +242,12 @@ lowestIndent = minimum . fmap lineIndent -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] parseLines ps = - fixForeignKeysAll . map mk . associateLines + fixForeignKeysAll . fmap mk . associateLines where mk :: LinesWithComments -> UnboundEntityDef mk lwc = - let ln :| rest = lwcLines lwc - (name :| entAttribs) = lineText ln - in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs rest + let entityLine :| fieldLines = lwcLines lwc + in setComments (lwcComments lwc) $ mkEntityDef ps entityLine fieldLines isDocComment :: Token -> Maybe Text isDocComment tok = @@ -427,21 +426,21 @@ lookupPrefix :: Text -> [Text] -> Maybe Text lookupPrefix prefix = msum . map (T.stripPrefix prefix) -- | Construct an entity definition. -mkEntityDef :: PersistSettings - -> Text -- ^ name - -> [Attr] -- ^ entity attributes - -> [Line] -- ^ indented lines - -> UnboundEntityDef -mkEntityDef ps name entattribs lines = +mkEntityDef + :: PersistSettings + -> Line -- ^ opening entity line + -> [Line] -- ^ remaining indented lines + -> UnboundEntityDef +mkEntityDef ps entityLine fieldLines = UnboundEntityDef foreigns $ EntityDef - { entityHaskell = entName - , entityDB = EntityNameDB $ getDbName ps (unTableNameDB name') entattribs + { entityHaskell = entNameHS + , entityDB = EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) entAttribs -- idField is the user-specified Id -- otherwise useAutoIdField -- but, adjust it if the user specified a Primary , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField - , entityAttrs = entattribs + , entityAttrs = entAttribs , entityFields = cols , entityUniques = uniqs , entityForeigns = [] @@ -451,23 +450,27 @@ mkEntityDef ps name entattribs lines = , entityComments = Nothing } where - entName = EntityNameHS (unTableNameDB name') - (isSum, name') = - case T.uncons name of - Just ('+', x) -> (True, TableNameDB x) - _ -> (False, TableNameDB name) - (attribs, extras) = splitExtras lines + (entityName :| entAttribs) = + lineText entityLine + + (isSum, entNameHS) = + case T.uncons entityName of + Just ('+', x) -> (True, EntityNameHS x) + _ -> (False, EntityNameHS entityName) + + (attribs, extras) = + splitExtras fieldLines textAttribs :: [[Text]] textAttribs = fmap tokenText <$> attribs - attribPrefix = flip lookupKeyVal entattribs + attribPrefix = flip lookupKeyVal entAttribs idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" | otherwise = Nothing (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> - let (i, p, u, f) = takeConstraint ps name' cols attr + let (i, p, u, f) = takeConstraint ps entNameHS cols attr squish xs m = xs `mappend` maybeToList m in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs @@ -485,7 +488,7 @@ mkEntityDef ps name entattribs lines = Nothing -> (acc, []) - autoIdField = mkAutoIdField ps entName (FieldNameDB `fmap` idName) idSqlType + autoIdField = mkAutoIdField ps entNameHS (FieldNameDB `fmap` idName) idSqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite setComposite Nothing fd = fd @@ -512,7 +515,7 @@ mkAutoIdField ps entName idName idSqlType = -- but that sucks for non-ID field -- TODO: use a sumtype FieldDef | IdFieldDef , fieldDB = fromMaybe (FieldNameDB $ psIdName ps) idName - , fieldType = FTTypeCon Nothing $ keyConName $ unEntityNameHS entName + , fieldType = FTTypeCon Nothing $ keyConName entName , fieldSqlType = idSqlType -- the primary field is actually a reference to the entity , fieldReference = ForeignRef entName defaultReferenceTypeCon @@ -526,8 +529,8 @@ mkAutoIdField ps entName idName idSqlType = defaultReferenceTypeCon :: FieldType defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" -keyConName :: Text -> Text -keyConName entName = entName `mappend` "Id" +keyConName :: EntityNameHS -> Text +keyConName entName = unEntityNameHS entName `mappend` "Id" splitExtras :: [Line] @@ -600,24 +603,24 @@ getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a takeConstraint :: PersistSettings - -> TableNameDB + -> EntityNameHS -> [FieldDef] -> [Text] -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) -takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' - where - takeConstraint' - | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) - | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) - | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) - | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) - | otherwise = (Nothing, Nothing, Just $ takeUniq ps (TableNameDB "") defs (n:rest), Nothing) -- retain compatibility with original unique constraint +takeConstraint ps entityName defs (n:rest) | isCapitalizedText n = takeConstraint' + where + takeConstraint' + | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps (unEntityNameHS entityName) defs rest, Nothing) + | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps entityName defs rest) + | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) + | n == "Id" = (Just $ takeId ps entityName (n:rest), Nothing, Nothing, Nothing) + | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) -- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. -- need to re-work takeCols function -takeId :: PersistSettings -> TableNameDB -> [Text] -> FieldDef -takeId ps tableName (n:rest) = +takeId :: PersistSettings -> EntityNameHS -> [Text] -> FieldDef +takeId ps entityName (n:rest) = setFieldDef $ fromMaybe (error "takeId: impossible!") $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) @@ -628,16 +631,16 @@ takeId ps tableName (n:rest) = addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) setFieldDef fd = fd { fieldReference = - ForeignRef (EntityNameHS (unTableNameDB tableName)) $ + ForeignRef entityName $ if fieldType fd == FTTypeCon Nothing keyCon then defaultReferenceTypeCon else fieldType fd } - keyCon = keyConName (unTableNameDB tableName) + keyCon = keyConName entityName -- this will be ignored if there is already an existing sql= -- TODO: I think there is a ! ignore syntax that would screw this up -- setIdName = ["sql=" `mappend` psIdName ps] -takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName +takeId _ (EntityNameHS tableName) _ = error $ "empty Id field for " `mappend` show tableName takeComposite @@ -661,11 +664,11 @@ takeComposite fields pkcols = -- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` -- Here using sql= sets the name of the constraint. takeUniq :: PersistSettings - -> TableNameDB + -> Text -> [FieldDef] -> [Text] -> UniqueDef -takeUniq ps (TableNameDB tableName) defs (n:rest) +takeUniq ps tableName defs (n : rest) | isCapitalizedText n = UniqueDef (ConstraintNameHS n) @@ -678,11 +681,12 @@ takeUniq ps (TableNameDB tableName) defs (n:rest) isSqlName a = "sql=" `T.isPrefixOf` a isNonField a = - isAttr a - || isSqlName a + isAttr a || isSqlName a (fields, nonFields) = break isNonField rest + attrs = filter isAttr nonFields + usualDbName = ConstraintNameDB $ psToDBName ps (tableName `T.append` n) sqlName :: Maybe ConstraintNameDB @@ -701,6 +705,7 @@ takeUniq ps (TableNameDB tableName) defs (n:rest) getDBName (d:ds) t | fieldHaskell d == FieldNameHS t = fieldDB d | otherwise = getDBName ds t + takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName @@ -715,14 +720,14 @@ data UnboundForeignDef = UnboundForeignDef takeForeign :: PersistSettings - -> TableNameDB + -> EntityNameHS -> [FieldDef] -> [Text] -> UnboundForeignDef -takeForeign ps tableName _defs = takeRefTable +takeForeign ps entityName _defs = takeRefTable where errorPrefix :: String - errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] " + errorPrefix = "invalid foreign key constraint on table[" ++ show (unEntityNameHS entityName) ++ "] " takeRefTable :: [Text] -> UnboundForeignDef takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" @@ -738,7 +743,7 @@ takeForeign ps tableName _defs = takeRefTable , foreignConstraintNameHaskell = ConstraintNameHS n , foreignConstraintNameDBName = - toFKConstraintNameDB ps tableName n + toFKConstraintNameDB ps entityName n , foreignFieldCascade = FieldCascade { fcOnDelete = onDelete , fcOnUpdate = onUpdate @@ -778,9 +783,9 @@ takeForeign ps tableName _defs = takeRefTable go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs -toFKConstraintNameDB :: PersistSettings -> TableNameDB -> Text -> ConstraintNameDB -toFKConstraintNameDB ps tableName n = - ConstraintNameDB $ psToDBName ps (toFKName tableName n) +toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> Text -> ConstraintNameDB +toFKConstraintNameDB ps entityName n = + ConstraintNameDB $ psToDBName ps (toFKName entityName n) where toFKName = unToFKName (psToFKName ps) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 9c1559c5d..1f6054bc2 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -453,13 +453,6 @@ data ForeignDef = ForeignDef } deriving (Show, Eq, Read, Ord, Lift) --- | A 'TableNameDB' represents the datastore-side name that @persistent@ --- will use for a table. --- --- @since 2.13.0.0 -newtype TableNameDB = TableNameDB { unTableNameDB :: Text } - deriving (Show, Eq, Read, Ord, Lift) - -- | This datatype describes how a foreign reference field cascades deletes -- or updates. -- From 6bced579e2990fd948bdab9a1ea074a614443364 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 21:42:48 +0100 Subject: [PATCH 08/12] Do the same thing but for the constraint --- persistent/Database/Persist/Quasi/Internal.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 48a3b69f6..2d035cbe9 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -121,7 +121,7 @@ data PersistSettings = PersistSettings defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id - , psToFKName = ToFKName $ \(EntityNameHS entName) name -> entName <> name + , psToFKName = ToFKName $ \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName , psStrictFields = True , psIdName = "id" } @@ -140,11 +140,11 @@ lowerCaseSettings = defaultPersistSettings -- -- @since 2.13.0.0 newtype ToFKName = ToFKName - { unToFKName :: EntityNameHS -> Text -> Text + { unToFKName :: EntityNameHS -> ConstraintNameHS -> Text } toFKNameInfixed :: Text -> ToFKName -toFKNameInfixed inf = ToFKName $ \(EntityNameHS entName) name -> entName <> inf <> name +toFKNameInfixed inf = ToFKName $ \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> inf <> conName -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] @@ -741,9 +741,9 @@ takeForeign ps entityName _defs = takeRefTable , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName , foreignConstraintNameHaskell = - ConstraintNameHS n + constraintName , foreignConstraintNameDBName = - toFKConstraintNameDB ps entityName n + toFKConstraintNameDB ps entityName constraintName , foreignFieldCascade = FieldCascade { fcOnDelete = onDelete , fcOnUpdate = onUpdate @@ -758,6 +758,8 @@ takeForeign ps entityName _defs = takeRefTable null pFields } where + constraintName = + ConstraintNameHS n (fields,attrs) = break ("!" `T.isPrefixOf`) rest (fFields, pFields) = case break (== "References") fields of (ffs, []) -> (ffs, []) @@ -783,9 +785,9 @@ takeForeign ps entityName _defs = takeRefTable go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs -toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> Text -> ConstraintNameDB -toFKConstraintNameDB ps entityName n = - ConstraintNameDB $ psToDBName ps (toFKName entityName n) +toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB +toFKConstraintNameDB ps entityName constraintName = + ConstraintNameDB $ psToDBName ps (toFKName entityName constraintName) where toFKName = unToFKName (psToFKName ps) From a2d4b7f95b18cef1607ac8c604ea9587b092cdbf Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 22:04:34 +0100 Subject: [PATCH 09/12] Expose more stuff --- persistent/Database/Persist/Quasi.hs | 19 ++++++++++++-- persistent/Database/Persist/Quasi/Internal.hs | 25 ++++++------------- persistent/test/main.hs | 17 ++++++++++--- 3 files changed, 38 insertions(+), 23 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 7e08dd677..b8122a460 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -416,11 +416,26 @@ module Database.Persist.Quasi , PersistSettings , upperCaseSettings , lowerCaseSettings + , setPsToFKName , setPsUseSnakeCaseForiegnKeys , nullable ) where +import Data.Text (Text) import Database.Persist.Quasi.Internal - +import Database.Persist.Types.Base + +-- | Set a custom function used to create the constraint name +-- for a foreign key. +-- +-- @since 2.13.0.0 +setPsToFKName :: (EntityNameHS -> ConstraintNameHS -> Text) -> PersistSettings -> PersistSettings +setPsToFKName setter ps = ps { psToFKName = setter } + +-- | A preset configuration function that puts an underscore +-- between the entity name and the constraint name when +-- creating a foreign key constraint name +-- +-- @since 2.13.0.0 setPsUseSnakeCaseForiegnKeys :: PersistSettings -> PersistSettings -setPsUseSnakeCaseForiegnKeys ps = ps { psToFKName = toFKNameInfixed "_" } +setPsUseSnakeCaseForiegnKeys = setPsToFKName (toFKNameInfixed "_") diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 2d035cbe9..bd1226800 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -16,7 +16,6 @@ module Database.Persist.Quasi.Internal , PersistSettings (..) , upperCaseSettings , lowerCaseSettings - , ToFKName (..) , toFKNameInfixed , nullable , Token (..) @@ -102,8 +101,9 @@ parseFieldType t0 = data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) - , psToFKName :: !ToFKName - -- ^ Function used to generate the FK name. Default value: @mappend@ + , psToFKName :: !(EntityNameHS -> ConstraintNameHS -> Text) + -- ^ A function for generating the constraint name, with access to + -- the entity and constraint names. Default value: @mappend@ -- -- @since 2.13.0.0 , psStrictFields :: !Bool @@ -121,7 +121,7 @@ data PersistSettings = PersistSettings defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id - , psToFKName = ToFKName $ \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName + , psToFKName = \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName , psStrictFields = True , psIdName = "id" } @@ -136,15 +136,9 @@ lowerCaseSettings = defaultPersistSettings in T.dropWhile (== '_') . T.concatMap go } --- | A function for converting a table and column name into a constraint name. --- --- @since 2.13.0.0 -newtype ToFKName = ToFKName - { unToFKName :: EntityNameHS -> ConstraintNameHS -> Text - } - -toFKNameInfixed :: Text -> ToFKName -toFKNameInfixed inf = ToFKName $ \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> inf <> conName +toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text +toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) = + entName <> inf <> conName -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] @@ -787,10 +781,7 @@ takeForeign ps entityName _defs = takeRefTable toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = - ConstraintNameDB $ psToDBName ps (toFKName entityName constraintName) - where - toFKName = - unToFKName (psToFKName ps) + ConstraintNameDB $ psToDBName ps (psToFKName ps entityName constraintName) data CascadePrefix = CascadeUpdate | CascadeDelete diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 10f485403..8a14f414e 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -369,8 +369,8 @@ Notification entityComments car `shouldBe` Just "This is a Car\n" entityComments vehicle `shouldBe` Nothing - it "should allow you to modify the FK name via provided function" $ do - let [user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) [st| + describe "foreign keys" $ do + let definitions = [st| User name Text emailFirst Text @@ -385,8 +385,17 @@ Notification Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond |] - let [notificationForeignDef] = entityForeigns notification - foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "notification_fk_noti_user" + + it "should allow you to modify the FK name via provided function" $ do + let flippedFK = \(EntityNameHS entName) (ConstraintNameHS conName) -> conName <> entName + let [user, notification] = parse (setPsToFKName flippedFK lowerCaseSettings) definitions + let [notificationForeignDef] = entityForeigns notification + foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "fk_noti_user_notification" + + it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do + let [user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [notificationForeignDef] = entityForeigns notification + foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "notification_fk_noti_user" describe "parseFieldType" $ do it "simple types" $ From 1f326f690e62b610df7ab9c4197ddbd64a5b0ad7 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 22:45:40 +0100 Subject: [PATCH 10/12] Some refactoring / cleanup --- persistent/Database/Persist/Quasi.hs | 4 +- persistent/Database/Persist/Quasi/Internal.hs | 90 ++++++++++++------- persistent/Database/Persist/TH.hs | 9 +- 3 files changed, 61 insertions(+), 42 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 2bd31a6b4..7bf538637 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -417,16 +417,14 @@ module Database.Persist.Quasi , PersistSettings , upperCaseSettings , lowerCaseSettings - , setPsToFKName - , setPsUseSnakeCaseForiegnKeys , nullable -- ** Getters and Setters , module Database.Persist.Quasi ) where import Data.Text (Text) +import Database.Persist.Names import Database.Persist.Quasi.Internal -import Database.Persist.Types.Base -- | Retrieve the function in the 'PersistSettings' that modifies the names into -- database names. diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index cb1845c98..04f54d4cf 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -237,13 +237,50 @@ lowestIndent = minimum . fmap lineIndent -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] -parseLines ps = - fixForeignKeysAll . fmap mk . associateLines +parseLines ps = do + fixForeignKeysAll . fmap (mkEntityDef ps . toParsedEntityDef) . associateLines + +data ParsedEntityDef = ParsedEntityDef + { parsedEntityDefComments :: [Text] + , parsedEntityDefEntityName :: EntityNameHS + , parsedEntityDefIsSum :: Bool + , parsedEntityDefEntityAttributes :: [Attr] + , parsedEntityDefFieldAttributes :: [[Token]] + , parsedEntityDefExtras :: M.Map Text [ExtraLine] + } + +entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) +entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) + where + entNameHS = + parsedEntityDefEntityName parsedEntDef + + entNameDB = + EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) (parsedEntityDefEntityAttributes parsedEntDef) + +toParsedEntityDef :: LinesWithComments -> ParsedEntityDef +toParsedEntityDef lwc = ParsedEntityDef + { parsedEntityDefComments = lwcComments lwc + , parsedEntityDefEntityName = entNameHS + , parsedEntityDefIsSum = isSum + , parsedEntityDefEntityAttributes = entAttribs + , parsedEntityDefFieldAttributes = attribs + , parsedEntityDefExtras = extras + } where - mk :: LinesWithComments -> UnboundEntityDef - mk lwc = - let entityLine :| fieldLines = lwcLines lwc - in setComments (lwcComments lwc) $ mkEntityDef ps entityLine fieldLines + entityLine :| fieldLines = + lwcLines lwc + + (entityName :| entAttribs) = + lineText entityLine + + (isSum, entNameHS) = + case T.uncons entityName of + Just ('+', x) -> (True, EntityNameHS x) + _ -> (False, EntityNameHS entityName) + + (attribs, extras) = + splitExtras fieldLines isDocComment :: Token -> Maybe Text isDocComment tok = @@ -312,11 +349,6 @@ associateLines lines = minimumIndentOf = lowestIndent . lwcLines -setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef -setComments [] = id -setComments comments = - overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) - fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] fixForeignKeysAll unEnts = map fixForeignKeys unEnts where @@ -427,46 +459,38 @@ data UnboundEntityDef , unboundEntityDef :: EntityDef } -overUnboundEntityDef - :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef -overUnboundEntityDef f ubed = - ubed { unboundEntityDef = f (unboundEntityDef ubed) } - -- | Construct an entity definition. mkEntityDef :: PersistSettings - -> Line -- ^ opening entity line - -> [Line] -- ^ remaining indented lines + -> ParsedEntityDef -- ^ parsed entity definition -> UnboundEntityDef -mkEntityDef ps entityLine fieldLines = +mkEntityDef ps parsedEntDef = UnboundEntityDef foreigns $ EntityDef { entityHaskell = entNameHS - , entityDB = EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) entAttribs + , entityDB = entNameDB -- idField is the user-specified Id -- otherwise useAutoIdField -- but, adjust it if the user specified a Primary , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField - , entityAttrs = entAttribs + , entityAttrs = parsedEntityDefEntityAttributes parsedEntDef , entityFields = cols , entityUniques = uniqs , entityForeigns = [] , entityDerives = concat $ mapMaybe takeDerives textAttribs - , entityExtra = extras - , entitySum = isSum - , entityComments = Nothing + , entityExtra = parsedEntityDefExtras parsedEntDef + , entitySum = parsedEntityDefIsSum parsedEntDef + , entityComments = + case parsedEntityDefComments parsedEntDef of + [] -> Nothing + comments -> Just (T.unlines comments) } where - (entityName :| entAttribs) = - lineText entityLine + (entNameHS, entNameDB) = + entityNamesFromParsedDef ps parsedEntDef - (isSum, entNameHS) = - case T.uncons entityName of - Just ('+', x) -> (True, EntityNameHS x) - _ -> (False, EntityNameHS entityName) - - (attribs, extras) = - splitExtras fieldLines + attribs = + parsedEntityDefFieldAttributes parsedEntDef textAttribs :: [[Text]] textAttribs = diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 399f054e1..92537520d 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -232,11 +232,8 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) -- so start with entityHaskell ent and accumulate embeddedHaskell em breakEntDefCycle :: EntityDef -> EntityDef breakEntDefCycle entDef = - overEntityFields (map (breakCycleField entName)) entDef + overEntityFields (map (breakCycleField (entityHaskell entDef))) entDef where - entName = - entityHaskell entDef - breakCycleField entName f = case fieldReference f of EmbedRef em -> @@ -402,10 +399,10 @@ setEmbedField entName allEntities field = ref = case mEmbedded allEntities (fieldType field) of Left _ -> fromMaybe NoReference $ do - entName <- lookupEmbedEntity allEntities field + refEntName <- lookupEmbedEntity allEntities field -- This can get corrected in mkEntityDefSqlTypeExp let placeholderIdType = FTTypeCon (Just "Data.Int") "Int64" - pure $ ForeignRef entName placeholderIdType + pure $ ForeignRef refEntName placeholderIdType Right em -> if embeddedHaskell em /= entName then EmbedRef em From 28395ce5536f58bd1c8e22c32f686d18bf2d68d7 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 22:53:32 +0100 Subject: [PATCH 11/12] Fix changelog indentation --- persistent/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index d78a07859..96274c860 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -3,7 +3,7 @@ ## 2.13.0.0 (unreleased) * [#1244](https://github.com/yesodweb/persistent/pull/1244) - * Implement config for customising the FK name + * Implement config for customising the FK name * [#1252](https://github.com/yesodweb/persistent/pull/1252) * `mkMigrate` now defers to `mkEntityDefList` and `migrateModels` instead of fixing the foreign key references itself. From 33767af0f04d47d074d4bd66f425fa70c5a3ab82 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 27 Apr 2021 23:16:45 +0100 Subject: [PATCH 12/12] Tidy code layout --- persistent/Database/Persist/Quasi/Internal.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 04f54d4cf..7e3a898e3 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -533,8 +533,12 @@ mkEntityDef ps parsedEntDef = go ft' _ -> field - autoIdField = mkAutoIdField ps entNameHS idSqlType - idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite + + autoIdField = + mkAutoIdField ps entNameHS idSqlType + + idSqlType = + maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite setComposite Nothing fd = fd setComposite (Just c) fd = fd