Implement test for behavior + modelling existing error behavior

persistent/test/Database/Persist/QuasiSpec.hs

@@ -7,6 +7,7 @@ module Database.Persist.QuasiSpec where
 
 import Prelude hiding (lines)
 
+import Control.Exception
 import Data.List hiding (lines)
 import Data.List.NonEmpty (NonEmpty(..), (<|))
 import qualified Data.List.NonEmpty as NEL
@@ -339,6 +340,89 @@ Notification
             entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n"
             entityComments (unboundEntityDef vehicle) `shouldBe` Nothing
 
+        describe "custom Id column" $ do
+            it "parses custom Id column" $ do
+                let definitions = [st|
+User
+    Id   Text
+    name Text
+    age  Int
+|]
+                let [user] = parse lowerCaseSettings definitions
+                getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
+                entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"
+                let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))
+                (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]
+                (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]
+                (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "Text"]
+                (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe`
+                  [ FieldNameHS "name"
+                  , FieldNameHS "age"
+                  ]
+
+            it "errors on duplicate custom Id column" $ do
+                let definitions = [st|
+User
+    Id   Text
+    Id   Text
+    name Text
+    age  Int
+    |]
+                let [user] = parse lowerCaseSettings definitions
+                    errMsg = [st|expected only one of: UnboundIdDef {unboundIdEntityName = EntityNameHS {unEntityNameHS = "User"}, unboundIdDBName = FieldNameDB {unFieldNameDB = "id"}, unboundIdAttrs = [FieldAttrOther "Text"], unboundIdCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}, unboundIdType = Just (FTTypeCon Nothing "Text")} UnboundIdDef {unboundIdEntityName = EntityNameHS {unEntityNameHS = "User"}, unboundIdDBName = FieldNameDB {unFieldNameDB = "id"}, unboundIdAttrs = [FieldAttrOther "Text"], unboundIdCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}, unboundIdType = Just (FTTypeCon Nothing "Text")}|]
+                evaluate (unboundEntityDef user) `shouldThrow`
+                  errorCall (T.unpack errMsg)
+
+        describe "primary declaration" $ do
+            it "parses Primary declaration" $ do
+                let definitions = [st|
+User
+    ref Text
+    name Text
+    age  Int
+    Primary ref
+|]
+                let [user] = parse lowerCaseSettings definitions
+                getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
+                entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"
+                let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))
+                (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]
+                (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]
+                (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "UserId"]
+                (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe`
+                  [ FieldNameHS "ref"
+                  , FieldNameHS "name"
+                  , FieldNameHS "age"
+                  ]
+
+            it "errors on duplicate custom Primary declaration" $ do
+                let definitions = [st|
+User
+    ref Text
+    name Text
+    age  Int
+    Primary ref
+    Primary name
+    |]
+                let [user] = parse lowerCaseSettings definitions
+                    errMsg = [st|expected only one of: UnboundCompositeDef {unboundCompositeCols = [FieldNameHS {unFieldNameHS = "ref"}], unboundCompositeAttrs = []} UnboundCompositeDef {unboundCompositeCols = [FieldNameHS {unFieldNameHS = "name"}], unboundCompositeAttrs = []}|]
+                evaluate (unboundEntityDef user) `shouldThrow`
+                  errorCall (T.unpack errMsg)
+
+            it "errors on conflicting Primary/Id declarations" $ do
+                let definitions = [st|
+User
+    Id Text
+    ref Text
+    name Text
+    age  Int
+    Primary ref
+    |]
+                let [user] = parse lowerCaseSettings definitions
+                    errMsg = [st|Specified both an ID field and a Primary field|]
+                evaluate (unboundEntityDef user) `shouldThrow`
+                  errorCall (T.unpack errMsg)
+
         describe "foreign keys" $ do
             let definitions = [st|
 User