Add coverage for parsing nested parens/lists in field types (#1376)

* Add coverage for nested parens/lists * Add TH spec * Add test modules to cabal file * Fix indentation and add to changelog
yesodweb · Mar 21, 2022 · f2e930f · f2e930f
1 parent b8484fa
commit f2e930f
Show file tree

Hide file tree

Showing 6 changed files with 81 additions and 0 deletions.
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -1,5 +1,7 @@
 # Changelog for persistent
 
+* [#1376](https://github.com/yesodweb/persistent/pull/1376)
+    * Add coverage for parsing nested parens/lists in field types
 * [#1370](https://github.com/yesodweb/persistent/pull/1370)
     * Add spec to assert Persistent.TH is the only import required when defining entities
 

diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
@@ -181,6 +181,8 @@ test-suite test
         Database.Persist.TH.MaybeFieldDefsSpec
         Database.Persist.TH.MultiBlockSpec
         Database.Persist.TH.MultiBlockSpec.Model
+        Database.Persist.TH.NestedSymbolsInTypeSpec
+        Database.Persist.TH.NestedSymbolsInTypeSpecImports
         Database.Persist.TH.OverloadedLabelSpec
         Database.Persist.TH.RequireOnlyPersistImportSpec
         Database.Persist.TH.SharedPrimaryKeyImportedSpec

diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs
@@ -510,6 +510,16 @@ CustomerTransfer
                 baz = FTTypeCon Nothing "Baz"
             parseFieldType "Foo [Bar] Baz" `shouldBe` Right (
                 foo `FTApp` bars `FTApp` baz)
+        it "nested list / parens (list inside parens)" $ do
+            let maybeCon = FTTypeCon Nothing "Maybe"
+                int = FTTypeCon Nothing "Int"
+            parseFieldType "Maybe (Maybe [Int])" `shouldBe` Right
+                (maybeCon `FTApp` (maybeCon `FTApp` FTList int))
+        it "nested list / parens (parens inside list)" $ do
+            let maybeCon = FTTypeCon Nothing "Maybe"
+                int = FTTypeCon Nothing "Int"
+            parseFieldType "[Maybe (Maybe Int)]" `shouldBe` Right
+                (FTList (maybeCon `FTApp` (maybeCon `FTApp` int)))
         it "fails on lowercase starts" $ do
             parseFieldType "nothanks" `shouldBe` Left "PSFail ('n',\"othanks\")"
 

diff --git a/persistent/test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs b/persistent/test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs
@@ -0,0 +1,44 @@
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Persist.TH.NestedSymbolsInTypeSpec where
+
+import Data.Map
+import Database.Persist.TH.NestedSymbolsInTypeSpecImports
+import TemplateTestImports
+
+mkPersist sqlSettings [persistLowerCase|
+PathEntitySimple
+    readOnly  (Maybe (SomePath ReadOnly))
+
+PathEntityNested
+    paths  (Maybe (Map Text [SomePath ReadWrite]))
+|]
+
+spec :: Spec
+spec = describe "NestedSymbolsInType" $ do
+    it "should support nested parens" $ do
+        let mkPathEntitySimple :: Maybe (SomePath ReadOnly) -> PathEntitySimple
+            mkPathEntitySimple = PathEntitySimple
+            pathEntitySimpleReadOnly' :: PathEntitySimple -> Maybe (SomePath ReadOnly)
+            pathEntitySimpleReadOnly' = pathEntitySimpleReadOnly
+        compiles
+
+    it "should support deeply nested parens + square brackets" $ do
+        let mkPathEntityNested :: Maybe (Map Text [SomePath ReadWrite]) -> PathEntityNested
+            mkPathEntityNested = PathEntityNested
+            pathEntityNestedPaths' :: PathEntityNested -> Maybe (Map Text [SomePath ReadWrite])
+            pathEntityNestedPaths' = pathEntityNestedPaths
+        compiles
+
+compiles :: Expectation
+compiles = True `shouldBe` True
diff --git a/persistent/test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs b/persistent/test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Database.Persist.TH.NestedSymbolsInTypeSpecImports where
+
+import Data.Proxy
+import TemplateTestImports
+
+data ReadOnly
+data ReadWrite
+
+newtype SomePath a = SomePath Text
+
+instance PersistFieldSql (SomePath a) where
+    sqlType _ = SqlString
+
+instance PersistField (SomePath a) where
+    toPersistValue (SomePath n) =
+        toPersistValue n
+    fromPersistValue v =
+        SomePath <$> fromPersistValue v
diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs
@@ -53,6 +53,7 @@ import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec
 import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec
 import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec
 import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec
+import qualified Database.Persist.TH.NestedSymbolsInTypeSpec as NestedSymbolsInTypeSpec
 import qualified Database.Persist.TH.MaybeFieldDefsSpec as MaybeFieldDefsSpec
 import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec
 import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec
@@ -174,6 +175,7 @@ spec :: Spec
 spec = describe "THSpec" $ do
     PersistWithSpec.spec
     KindEntitiesSpec.spec
+    NestedSymbolsInTypeSpec.spec
     OverloadedLabelSpec.spec
     SharedPrimaryKeySpec.spec
     SharedPrimaryKeyImportedSpec.spec