diff --git a/persistent-redis/persistent-redis.cabal b/persistent-redis/persistent-redis.cabal index c7637e984..6d3f609ce 100644 --- a/persistent-redis/persistent-redis.cabal +++ b/persistent-redis/persistent-redis.cabal @@ -29,7 +29,7 @@ library , scientific >= 0.3.5 && < 0.4 , text >= 1.2 , time >= 1.6 - , transformers >= 0.5 + , transformers >= 0.5 , utf8-string >= 1.0 && < 1.1 exposed-modules: Database.Persist.Redis diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 47c2d78b0..00db8bf94 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,6 +2,8 @@ ## 2.14.6.0 (unreleased) +* [#1477](https://github.com/yesodweb/persistent/pull/1477) + * Qualified references to other tables will work * [#1503](https://github.com/yesodweb/persistent/pull/1503) * Create Haddocks from entity documentation comments * [1497](https://github.com/yesodweb/persistent/pull/1497) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index dfc25ef25..f4b0bde24 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -464,7 +464,9 @@ liftAndFixKeys mps emEntities entityMap unboundEnt = (fieldRef', sqlTyp') = case extractForeignRef entityMap ufd of Just targetTable -> - (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTable)) + let targetTableQualified = + fromMaybe targetTable (guessFieldReferenceQualified ufd) + in (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTableQualified)) Nothing -> (lift NoReference, liftSqlTypeExp sqlTypeExp) @@ -537,6 +539,30 @@ guessReference ft = guessReferenceText (Just next) ] +guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS +guessFieldReferenceQualified = guessReferenceQualified . unboundFieldType + +guessReferenceQualified :: FieldType -> Maybe EntityNameHS +guessReferenceQualified ft = + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon mmod (checkIdSuffix -> Just tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] + mkDefaultKey :: MkPersistSettings -> FieldNameDB diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 2d84727b1..ed971977d 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -76,7 +76,7 @@ import qualified Database.Persist.TH.TypeLitFieldDefsSpec as TypeLitFieldDefsSpe -- machinery type TextId = Text -share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }] [persistUpperCase| +share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase| Person json name Text @@ -102,6 +102,10 @@ CustomIdName Id sql=id_col name Text deriving Show Eq + +QualifiedReference + jsonEncoding JsonEncodingSpec.JsonEncodingId + |] mkPersist sqlSettings [persistLowerCase| @@ -207,6 +211,13 @@ spec = describe "THSpec" $ do CommentSpec.spec EntityHaddockSpec.spec CompositeKeyStyleSpec.spec + it "QualifiedReference" $ do + let ed = entityDef @QualifiedReference Proxy + [FieldDef {..}] = entityFields ed + fieldType `shouldBe` FTTypeCon (Just "JsonEncodingSpec") "JsonEncodingId" + fieldSqlType `shouldBe` sqlType @JsonEncodingSpec.JsonEncodingId Proxy + fieldReference `shouldBe` ForeignRef (EntityNameHS "JsonEncoding") + describe "TestDefaultKeyCol" $ do let EntityIdField FieldDef{..} = entityId (entityDef (Proxy @TestDefaultKeyCol))