Handle qualified table name (#1477)

* handle qualified table name * further handle qualifier. and drop the qualifier when entityMap lookup in extractForeignRef * working solution (pass tests and handle conflicting name in Proxy) * remove stale code * merge master * neat * changelog --------- Co-authored-by: parsonsmatt <parsonsmatt@gmail.com>
yesodweb · Oct 3, 2023 · bd32280 · bd32280
1 parent 68b7ca7
commit bd32280
Show file tree

Hide file tree

Showing 4 changed files with 42 additions and 3 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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))