Always create SymbolToField for "id"

- given there is always a {EntityName}Id type
yesodweb · Jun 28, 2023 · 17cbadb · 17cbadb
1 parent 2a26141
commit 17cbadb
Show file tree

Hide file tree

Showing 2 changed files with 25 additions and 19 deletions.
diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
@@ -2980,11 +2980,7 @@ mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do
                 mkEntityFieldConstr fieldHaskellName
         mkInstance fieldNameT fieldTypeT entityFieldConstr
 
-    mkey <-
-        case unboundPrimarySpec ed of
-            NaturalKey _ ->
-                pure []
-            _ -> do
+    mkey <- do
                 let
                     fieldHaskellName =
                         FieldNameHS "Id"

diff --git a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs
@@ -1,23 +1,23 @@
-{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GADTs                      #-}
+{-# 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 TypeFamilies               #-}
-{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-}
 
 module Database.Persist.TH.OverloadedLabelSpec where
 
-import           TemplateTestImports
+import TemplateTestImports
 
 mkPersist sqlSettings [persistUpperCase|
 
@@ -33,6 +33,10 @@ Dog
 Organization
     name    String
 
+Student
+    userId  UserId
+    departmentName String
+    Primary userId
 |]
 
 spec :: Spec
@@ -60,5 +64,11 @@ spec = describe "OverloadedLabels" $ do
 
         compiles
 
+    it "works for Primary labels" $ do
+        let StudentId = #id
+            studentId = #id :: EntityField Student StudentId
+
+        compiles
+
 compiles :: IO ()
 compiles = pure ()