From 630dab2f68b676ac3f6744d608e725dc64c76a76 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 27 Apr 2021 11:27:03 -0600 Subject: [PATCH 1/7] wtf --- persistent/ChangeLog.md | 5 ++ persistent/Database/Persist/TH.hs | 21 +++++++- persistent/persistent.cabal | 2 + .../Database/Persist/TH/MultiBlockSpec.hs | 51 +++++++++++++++++++ .../Persist/TH/MultiBlockSpec/Model.hs | 33 ++++++++++++ persistent/test/Database/Persist/THSpec.hs | 3 ++ 6 files changed, 113 insertions(+), 2 deletions(-) create mode 100644 persistent/test/Database/Persist/TH/MultiBlockSpec.hs create mode 100644 persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index d9fe2e4fd..6fcf405d4 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -66,6 +66,11 @@ functionality, please comment with your needs on the GitHub issue tracker. We may un-deprecate it, or we may provide a new and better means of facilitating a solution to your problem. +* []() + * `mkPersist` now checks to see if an instance already exists for + `PersistEntity` for the inputs. This allows you to pass `EntityDef`s into + `mkPersist` which have been previously defined, which allows the foreign + field information to be generated more reliably across modules. ## 2.12.1.1 diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 3421b62df..174b3af5d 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -473,6 +473,14 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = -- 'EntityDef's. Works well with the persist quasi-quoter. mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] mkPersist mps ents' = do + ents <- + filterM isNotPersistEntityInstanceAlready + $ embedEntityDefs + $ map (setDefaultIdFields mps) + $ ents' + let + entityMap = + constructEntityMap ents requireExtensions [ [TypeFamilies], [GADTs, ExistentialQuantification] , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] @@ -490,9 +498,18 @@ mkPersist mps ents' = do , uniqueKeyInstances , symbolToFieldInstances ] + +-- we can't just use 'isInstance' because TH throws an error +isNotPersistEntityInstanceAlready :: EntityDef -> Q Bool +isNotPersistEntityInstanceAlready ed = do + info <- reify entityName + fmap not (isInstance ''PersistEntity [entityType]) + where - ents = embedEntityDefs $ map (setDefaultIdFields mps) ents' - entityMap = constructEntityMap ents + entityName = + mkName . T.unpack . unEntityNameHS . getEntityHaskellName $ ed + entityType = + ConT entityName setDefaultIdFields :: MkPersistSettings -> EntityDef -> EntityDef setDefaultIdFields mps ed diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 4e9dd8f5c..712d03fe7 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -164,6 +164,8 @@ test-suite test Database.Persist.TH.OverloadedLabelSpec Database.Persist.TH.SharedPrimaryKeyImportedSpec Database.Persist.TH.SharedPrimaryKeySpec + Database.Persist.TH.MultiBlockSpec + Database.Persist.TH.MultiBlockSpec.Model Database.Persist.THSpec TemplateTestImports Database.Persist.TH.SharedPrimaryKeySpec diff --git a/persistent/test/Database/Persist/TH/MultiBlockSpec.hs b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs new file mode 100644 index 000000000..ee3001c6a --- /dev/null +++ b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.MultiBlockSpec where + +import TemplateTestImports + + +import Database.Persist.TH.MultiBlockSpec.Model + +share + [ mkPersist sqlSettings . mappend importDefList + ] + [persistLowerCase| + +MBBar + name Text + age Int + user UserId +|] + +spec :: Spec +spec = describe "MultiBlockSpec" $ do + describe "MBBar" $ do + let + edef = + entityDef $ Proxy @MBBar + describe "Foreign Key Works" $ do + let + [n, a, userRef] = + getEntityFields edef + it "has foreign ref" $ do + fieldReference userRef + `shouldBe` + ForeignRef (EntityNameHS "User") (FTTypeCon Nothing "") + + + diff --git a/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs b/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs new file mode 100644 index 000000000..318e35528 --- /dev/null +++ b/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.MultiBlockSpec.Model where + +import TemplateTestImports + +share + [ mkPersist sqlSettings + , mkEntityDefList "importDefList" + ] + [persistLowerCase| + +User + name Text + age Int + + deriving Eq Show +|] + diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 75ca735b8..592fbcc82 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -45,6 +45,8 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports + +import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec @@ -150,6 +152,7 @@ spec = describe "THSpec" $ do MigrationOnlySpec.spec EmbedSpec.spec DiscoverEntitiesSpec.spec + MultiBlockSpec.spec describe "TestDefaultKeyCol" $ do let FieldDef{..} = entityId (entityDef (Proxy @TestDefaultKeyCol)) From 29280f3911e589420e10667638f9c62d5a225e67 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 27 Apr 2021 12:10:47 -0600 Subject: [PATCH 2/7] hmmm --- persistent/Database/Persist/Quasi/Internal.hs | 97 +++++++++++-------- persistent/Database/Persist/TH.hs | 21 ++-- .../Database/Persist/TH/MultiBlockSpec.hs | 20 +++- .../Persist/TH/MultiBlockSpec/Model.hs | 12 +++ 4 files changed, 94 insertions(+), 56 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index b066585ae..866bbdf00 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -336,16 +336,17 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts unEntityNameDB (entityDB pent) oldDbName = unEntityNameDB (foreignRefTableDBName fdef) - in fdef - { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - , foreignRefTableDBName = - EntityNameDB dbname - , foreignConstraintNameDBName = - ConstraintNameDB - . T.replace oldDbName dbname . unConstraintNameDB - $ foreignConstraintNameDBName fdef - } + in + fdef + { foreignFields = map snd fds_ffs + , foreignNullable = setNull $ map fst fds_ffs + , foreignRefTableDBName = + EntityNameDB dbname + , foreignConstraintNameDBName = + ConstraintNameDB + . T.replace oldDbName dbname . unConstraintNameDB + $ foreignConstraintNameDBName fdef + } Nothing -> error $ "no primary key found fdef="++show fdef++ " ent="++show ent where @@ -722,42 +723,54 @@ takeForeign ps tableName _defs = takeRefTable errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] " takeRefTable :: [Text] -> UnboundForeignDef - takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" - takeRefTable (refTableName:restLine) = go restLine Nothing Nothing + takeRefTable [] = + error $ errorPrefix ++ " expecting foreign table name" + takeRefTable (refTableName:restLine) = + go restLine Nothing Nothing where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n) - = UnboundForeignDef fFields pFields $ ForeignDef - { foreignRefTableHaskell = - EntityNameHS refTableName - , foreignRefTableDBName = - EntityNameDB $ psToDBName ps refTableName - , foreignConstraintNameHaskell = - ConstraintNameHS n - , foreignConstraintNameDBName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` n) - , foreignFieldCascade = FieldCascade - { fcOnDelete = onDelete - , fcOnUpdate = onUpdate + go (n:rest) onDelete onUpdate + | not (T.null n) && isLower (T.head n) = + UnboundForeignDef fFields pFields $ ForeignDef + { foreignRefTableHaskell = + EntityNameHS refTableName + , foreignRefTableDBName = + EntityNameDB $ psToDBName ps refTableName + , foreignConstraintNameHaskell = + ConstraintNameHS n + , foreignConstraintNameDBName = + ConstraintNameDB $ psToDBName ps (tableName `T.append` n) + , foreignFieldCascade = FieldCascade + { fcOnDelete = onDelete + , fcOnUpdate = onUpdate + } + , foreignFields = + [] + , foreignAttrs = + attrs + , foreignNullable = + False + , foreignToPrimary = + null pFields } - , foreignFields = - [] - , foreignAttrs = - attrs - , foreignNullable = - False - , foreignToPrimary = - null pFields - } where - (fields,attrs) = break ("!" `T.isPrefixOf`) rest - (fFields, pFields) = case break (== "References") fields of - (ffs, []) -> (ffs, []) - (ffs, _ : pfs) -> case (length ffs, length pfs) of - (flen, plen) | flen == plen -> (ffs, pfs) - (flen, plen) -> error $ errorPrefix ++ concat - [ "Found ", show flen, " foreign fields but " - , show plen, " parent fields" ] + (fields, attrs) = + break ("!" `T.isPrefixOf`) rest + (fFields, pFields) = + case break (== "References") fields of + (ffs, []) -> + (ffs, []) + (ffs, _ : pfs) -> + case (length ffs, length pfs) of + (flen, plen) + | flen == plen -> + (ffs, pfs) + (flen, plen) -> + error $ errorPrefix ++ concat + [ "Found " , show flen + , " foreign fields but " + , show plen, " parent fields" + ] go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = case onDelete' of diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 174b3af5d..6a9a3358b 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -474,7 +474,8 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] mkPersist mps ents' = do ents <- - filterM isNotPersistEntityInstanceAlready + -- filterM (const (pure True)) -- isNotPersistEntityInstanceAlready + filterM shouldGenerateCode $ embedEntityDefs $ map (setDefaultIdFields mps) $ ents' @@ -500,16 +501,18 @@ mkPersist mps ents' = do ] -- we can't just use 'isInstance' because TH throws an error -isNotPersistEntityInstanceAlready :: EntityDef -> Q Bool -isNotPersistEntityInstanceAlready ed = do - info <- reify entityName - fmap not (isInstance ''PersistEntity [entityType]) - +shouldGenerateCode :: EntityDef -> Q Bool +shouldGenerateCode ed = do + mtyp <- lookupTypeName entityName + case mtyp of + Nothing -> do + pure True + Just typeName -> do + instanceExists <- isInstance ''PersistEntity [ConT typeName] + pure (not instanceExists) where entityName = - mkName . T.unpack . unEntityNameHS . getEntityHaskellName $ ed - entityType = - ConT entityName + T.unpack . unEntityNameHS . getEntityHaskellName $ ed setDefaultIdFields :: MkPersistSettings -> EntityDef -> EntityDef setDefaultIdFields mps ed diff --git a/persistent/test/Database/Persist/TH/MultiBlockSpec.hs b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs index ee3001c6a..2af478299 100644 --- a/persistent/test/Database/Persist/TH/MultiBlockSpec.hs +++ b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs @@ -30,6 +30,10 @@ MBBar name Text age Int user UserId + profile MBDogId + + -- TODO: make the QQ not care about this table being missing + -- Foreign MBCompositePrimary bar_to_comp name age |] spec :: Spec @@ -40,12 +44,18 @@ spec = describe "MultiBlockSpec" $ do entityDef $ Proxy @MBBar describe "Foreign Key Works" $ do let - [n, a, userRef] = + [n, a, userRef, profileRef] = getEntityFields edef - it "has foreign ref" $ do + it "User reference works" $ do fieldReference userRef `shouldBe` - ForeignRef (EntityNameHS "User") (FTTypeCon Nothing "") - - + ForeignRef + (EntityNameHS "User") + (FTTypeCon (Just "Data.Int") "Int64") + it "Primary key reference works" $ do + fieldReference profileRef + `shouldBe` + ForeignRef + (EntityNameHS "MBDog") + (FTTypeCon (Just "Data.Int") "Int64") diff --git a/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs b/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs index 318e35528..21b571169 100644 --- a/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs +++ b/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -29,5 +30,16 @@ User age Int deriving Eq Show + +MBDog + name Text + Primary name + +MBCompositePrimary + name Text + age Int + + Primary name age + |] From 94ff49fb91db66634321eec9674df919166e5f56 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 27 Apr 2021 12:26:58 -0600 Subject: [PATCH 3/7] refactor and tidy --- persistent/Database/Persist/Quasi/Internal.hs | 201 ++++++++++-------- 1 file changed, 113 insertions(+), 88 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 866bbdf00..4fa33734b 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -321,72 +321,86 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts -- the names of the referenced columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = - case mfdefs of - Just fdefs -> - if length foreignFieldTexts /= length fdefs - then - lengthError fdefs - else - let - fds_ffs = - zipWith toForeignFields - foreignFieldTexts - fdefs - dbname = - unEntityNameDB (entityDB pent) - oldDbName = - unEntityNameDB (foreignRefTableDBName fdef) - in - fdef - { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - , foreignRefTableDBName = - EntityNameDB dbname - , foreignConstraintNameDBName = - ConstraintNameDB - . T.replace oldDbName dbname . unConstraintNameDB - $ foreignConstraintNameDBName fdef - } - Nothing -> - error $ "no primary key found fdef="++show fdef++ " ent="++show ent + let + errorNoPrimaryKeyFound = + error $ "no primary key found fdef="++show fdef++ " ent="++show ent + fdefs = + fromMaybe errorNoPrimaryKeyFound mfdefs + pentError = + error $ "could not find table " ++ show (foreignRefTableHaskell fdef) + ++ " fdef=" ++ show fdef ++ " allnames=" + ++ show (map (unEntityNameHS . entityHaskell . unboundEntityDef) unEnts) + ++ "\n\nents=" ++ show ents + pent = + fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup + mfdefs = + case parentFieldTexts of + [] -> entitiesPrimary pent + _ -> Just $ map (getFieldDef pent . FieldNameHS) parentFieldTexts + in + if length foreignFieldTexts /= length fdefs + then + lengthError fdefs + else + let + fds_ffs = + zipWith toForeignFields + foreignFieldTexts + fdefs + dbname = + unEntityNameDB (entityDB pent) + oldDbName = + unEntityNameDB (foreignRefTableDBName fdef) + in + fdef + { foreignFields = map snd fds_ffs + , foreignNullable = setNull $ map fst fds_ffs + , foreignRefTableDBName = + EntityNameDB dbname + , foreignConstraintNameDBName = + ConstraintNameDB + . T.replace oldDbName dbname . unConstraintNameDB + $ foreignConstraintNameDBName fdef + } where - pentError = - error $ "could not find table " ++ show (foreignRefTableHaskell fdef) - ++ " fdef=" ++ show fdef ++ " allnames=" - ++ show (map (unEntityNameHS . entityHaskell . unboundEntityDef) unEnts) - ++ "\n\nents=" ++ show ents - pent = - fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup - mfdefs = case parentFieldTexts of - [] -> entitiesPrimary pent - _ -> Just $ map (getFd pent . FieldNameHS) parentFieldTexts - setNull :: [FieldDef] -> Bool - setNull [] = error "setNull: impossible!" - setNull (fd:fds) = let nullSetting = isNull fd in - if all ((nullSetting ==) . isNull) fds then nullSetting - else error $ "foreign key columns must all be nullable or non-nullable" + setNull [] = + error "setNull: impossible!" + setNull (fd:fds) = + let + nullSetting = isNull fd + in + if all ((nullSetting ==) . isNull) fds + then nullSetting + else error $ + "foreign key columns must all be nullable or non-nullable" ++ show (map (unFieldNameHS . fieldHaskell) (fd:fds)) - isNull = (NotNullable /=) . nullable . fieldAttrs - toForeignFields :: Text -> FieldDef + isNull = + (NotNullable /=) . nullable . fieldAttrs + + toForeignFields + :: Text + -> FieldDef -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)) - toForeignFields fieldText pfd = - case chktypes fd haskellField pfd of - Just err -> error err - Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) + toForeignFields fieldText parentFieldDef = + case checkTypes fieldDef parentFieldDef of + Just err -> + error err + Nothing -> + (fieldDef, ((haskellField, fieldDB fieldDef), (parentFieldHaskellName, parentFieldNameDB))) where - fd = getFd ent haskellField - + fieldDef = getFieldDef ent haskellField haskellField = FieldNameHS fieldText - (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) - - chktypes ffld _fkey pfld = - if fieldType ffld == fieldType pfld then Nothing - else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) - - getFd :: EntityDef -> FieldNameHS -> FieldDef - getFd entity t = go (keyAndEntityFields entity) + parentFieldHaskellName = fieldHaskell parentFieldDef + parentFieldNameDB = fieldDB parentFieldDef + checkTypes foreignField parentField = + if fieldType foreignField == fieldType parentField + then Nothing + else Just $ "fieldType mismatch: " ++ show (fieldType foreignField) ++ ", " ++ show (fieldType parentField) + + getFieldDef :: EntityDef -> FieldNameHS -> FieldDef + getFieldDef entity t = go (keyAndEntityFields entity) where go [] = error $ "foreign key constraint for: " ++ show (unEntityNameHS $ entityHaskell entity) ++ " unknown column: " ++ show t @@ -705,11 +719,15 @@ takeUniq _ tableName _ xs = ++ "] expecting an uppercase constraint name xs=" ++ show xs -data UnboundForeignDef = UnboundForeignDef - { _unboundForeignFields :: [Text] -- ^ fields in the parent entity - , _unboundParentFields :: [Text] -- ^ fields in parent entity - , _unboundForeignDef :: ForeignDef - } +data UnboundForeignDef + = UnboundForeignDef + { _unboundForeignFields :: [Text] + -- ^ fields in the parent entity + , _unboundParentFields :: [Text] + -- ^ fields in parent entity + , _unboundForeignDef :: ForeignDef + -- ^ The 'ForeignDef' which needs information filled in. + } takeForeign :: PersistSettings @@ -729,34 +747,41 @@ takeForeign ps tableName _defs = takeRefTable go restLine Nothing Nothing where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (n:rest) onDelete onUpdate - | not (T.null n) && isLower (T.head n) = - UnboundForeignDef fFields pFields $ ForeignDef - { foreignRefTableHaskell = - EntityNameHS refTableName - , foreignRefTableDBName = - EntityNameDB $ psToDBName ps refTableName - , foreignConstraintNameHaskell = - ConstraintNameHS n - , foreignConstraintNameDBName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` n) - , foreignFieldCascade = FieldCascade - { fcOnDelete = onDelete - , fcOnUpdate = onUpdate - } - , foreignFields = - [] - , foreignAttrs = - attrs - , foreignNullable = - False - , foreignToPrimary = - null pFields + go (constraintName:rest) onDelete onUpdate + | not (T.null constraintName) && isLower (T.head constraintName) = + UnboundForeignDef + { _unboundForeignFields = + foreignFields + , _unboundParentFields = + parentFields + , _unboundForeignDef = + ForeignDef + { foreignRefTableHaskell = + EntityNameHS refTableName + , foreignRefTableDBName = + EntityNameDB $ psToDBName ps refTableName + , foreignConstraintNameHaskell = + ConstraintNameHS constraintName + , foreignConstraintNameDBName = + ConstraintNameDB $ psToDBName ps (tableName `T.append` constraintName) + , foreignFieldCascade = FieldCascade + { fcOnDelete = onDelete + , fcOnUpdate = onUpdate + } + , foreignFields = + [] + , foreignAttrs = + attrs + , foreignNullable = + False + , foreignToPrimary = + null parentFields + } } where (fields, attrs) = break ("!" `T.isPrefixOf`) rest - (fFields, pFields) = + (foreignFields, parentFields) = case break (== "References") fields of (ffs, []) -> (ffs, []) From 5e3ce155061bf7c537a01c10db730e6216b30add Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 27 Apr 2021 12:35:48 -0600 Subject: [PATCH 4/7] are foreign fields never right ?! --- .../Database/Persist/TH/MultiBlockSpec.hs | 25 ++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/persistent/test/Database/Persist/TH/MultiBlockSpec.hs b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs index 2af478299..2b349f913 100644 --- a/persistent/test/Database/Persist/TH/MultiBlockSpec.hs +++ b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs @@ -26,10 +26,19 @@ share ] [persistLowerCase| +Thing + name Text + Primary name + +ThingAuto + name Text + MBBar name Text age Int user UserId + thing ThingId + thingAuto ThingAutoId profile MBDogId -- TODO: make the QQ not care about this table being missing @@ -44,7 +53,7 @@ spec = describe "MultiBlockSpec" $ do entityDef $ Proxy @MBBar describe "Foreign Key Works" $ do let - [n, a, userRef, profileRef] = + [n, a, userRef, thingRef, thingAutoRef, profileRef] = getEntityFields edef it "User reference works" $ do fieldReference userRef @@ -59,3 +68,17 @@ spec = describe "MultiBlockSpec" $ do ForeignRef (EntityNameHS "MBDog") (FTTypeCon (Just "Data.Int") "Int64") + + it "Thing ref works (same block)" $ do + fieldReference thingRef + `shouldBe` + ForeignRef + (EntityNameHS "Thing") + (FTTypeCon (Just "Data.Int") "Int64") + + it "ThingAuto ref works (same block)" $ do + fieldReference thingAutoRef + `shouldBe` + ForeignRef + (EntityNameHS "ThingAuto") + (FTTypeCon (Just "Data.Int") "Int64") From 403c5f2e176e8d6c813c2a119fc3b13c2f874ce7 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 27 Apr 2021 12:38:58 -0600 Subject: [PATCH 5/7] changelog --- persistent/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 6fcf405d4..81cb6fffa 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -66,7 +66,7 @@ functionality, please comment with your needs on the GitHub issue tracker. We may un-deprecate it, or we may provide a new and better means of facilitating a solution to your problem. -* []() +* [#1255](https://github.com/yesodweb/persistent/pull/1255) * `mkPersist` now checks to see if an instance already exists for `PersistEntity` for the inputs. This allows you to pass `EntityDef`s into `mkPersist` which have been previously defined, which allows the foreign From 60ee0c5f69743063b1b88979148f5b93f5394b3c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 27 Apr 2021 12:43:52 -0600 Subject: [PATCH 6/7] fix comments --- persistent/Database/Persist/Quasi/Internal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 4fa33734b..1054b9ff3 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -722,9 +722,9 @@ takeUniq _ tableName _ xs = data UnboundForeignDef = UnboundForeignDef { _unboundForeignFields :: [Text] - -- ^ fields in the parent entity + -- ^ fields in the source entity , _unboundParentFields :: [Text] - -- ^ fields in parent entity + -- ^ fields in target entity , _unboundForeignDef :: ForeignDef -- ^ The 'ForeignDef' which needs information filled in. } From 305b290d5c2e0479cf9f63d312fab492aad6da05 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 27 Apr 2021 12:44:56 -0600 Subject: [PATCH 7/7] dead code --- persistent/Database/Persist/TH.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 6a9a3358b..e711c449d 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -474,7 +474,6 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] mkPersist mps ents' = do ents <- - -- filterM (const (pure True)) -- isNotPersistEntityInstanceAlready filterM shouldGenerateCode $ embedEntityDefs $ map (setDefaultIdFields mps)