diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index d9fe2e4fd..81cb6fffa 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. +* [#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 + field information to be generated more reliably across modules. ## 2.12.1.1 diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index b066585ae..1054b9ff3 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -321,71 +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 @@ -704,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 source entity + , _unboundParentFields :: [Text] + -- ^ fields in target entity + , _unboundForeignDef :: ForeignDef + -- ^ The 'ForeignDef' which needs information filled in. + } takeForeign :: PersistSettings @@ -722,42 +741,61 @@ 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 (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 + } } - , 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 + (foreignFields, parentFields) = + 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 3421b62df..e711c449d 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 shouldGenerateCode + $ embedEntityDefs + $ map (setDefaultIdFields mps) + $ ents' + let + entityMap = + constructEntityMap ents requireExtensions [ [TypeFamilies], [GADTs, ExistentialQuantification] , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] @@ -490,9 +498,20 @@ mkPersist mps ents' = do , uniqueKeyInstances , symbolToFieldInstances ] + +-- we can't just use 'isInstance' because TH throws an error +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 - ents = embedEntityDefs $ map (setDefaultIdFields mps) ents' - entityMap = constructEntityMap ents + entityName = + T.unpack . unEntityNameHS . getEntityHaskellName $ ed 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..2b349f913 --- /dev/null +++ b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs @@ -0,0 +1,84 @@ +{-# 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| + +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 + -- Foreign MBCompositePrimary bar_to_comp name age +|] + +spec :: Spec +spec = describe "MultiBlockSpec" $ do + describe "MBBar" $ do + let + edef = + entityDef $ Proxy @MBBar + describe "Foreign Key Works" $ do + let + [n, a, userRef, thingRef, thingAutoRef, profileRef] = + getEntityFields edef + it "User reference works" $ do + fieldReference userRef + `shouldBe` + 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") + + 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") 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..21b571169 --- /dev/null +++ b/persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# 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 + +MBDog + name Text + Primary name + +MBCompositePrimary + name Text + age Int + + Primary name age + +|] + 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))