Add a guide section on arrays with type sigs

.hlint.yaml

@@ -1,3 +1,5 @@
 - ignore: {name: "Eta reduce"}
 - ignore: {name: "Avoid lambda"}
 - ignore: {name: "Avoid lambda using `infix`"}
+- ignore: {name: "Use newtype instead of data"}
+- ignore: {name: "Use tuple-section"}

docs/src/Guides.md

@@ -59,4 +59,17 @@ getEntity key = do
     -- business logic component.
 ```
 
+## Arrays of items
+
+Sometimes we want a field to be an array of items, like UUIDs. For such inner types, PostreSQL asks of you to
+provide an explicit type signature. The case of arrays is interesting because you need to adapt to the syntax
+wanted by PostreSQL: 
+
+* An empty array is `{}`;
+* An array with elements is `ARRAY[item1, item2, …, itemN]`
+* An array with elements and a type signature is `ARRAY[item1, item2, …, itemN]::uuid[]`
+
+
+
 [MonadError]: https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Except.html#t:MonadError
+

src/Database/PostgreSQL/Entity/Internal/BlogPost.hs

@@ -29,10 +29,10 @@ import Database.PostgreSQL.Transact (DBT)
 import GHC.Generics (Generic)
 import GHC.OverloadedLabels (IsLabel (..))
 import GHC.Records (HasField (..))
-
 import Data.ByteString.Builder (byteString, char8)
 import qualified Data.List as List
 import qualified Data.Vector as Vector
+
 import Database.PostgreSQL.Entity (insert, insertMany)
 import Database.PostgreSQL.Entity.Internal.QQ (field)
 import Database.PostgreSQL.Entity.Types (Entity (..), GenericEntity, PrimaryKey, TableName)

src/Database/PostgreSQL/Entity/Internal/QQ.hs

@@ -30,7 +30,7 @@ import Text.Parsec (Parsec, anyChar, manyTill, parse, space, spaces, string, try
 -- >   primaryKey = [field| blogpost_id |]
 -- >   fields = [ [field| blogpost_id |]
 -- >            , [field| author_id |]
--- >            , [field| uuid_list :: uuid[] |] -- ← This is where we specify an optional PostgreSQL type annotation
+-- >            , [field| uuid_list |] -- ← We will use a newtype wrapper to alter the 'ToField' instance
 -- >            , [field| title |]
 -- >            , [field| content |]
 -- >            , [field| created_at |]

test/EntitySpec.hs

@@ -10,28 +10,32 @@ import Control.Monad.IO.Class
 import Data.Text (Text)
 import qualified Data.UUID as UUID
 import qualified Data.Vector as V
+import Database.PostgreSQL.Entity.Types
 import Database.PostgreSQL.Entity (_joinSelectWithFields, _where, delete, deleteByField, joinSelectOneByField,
                                    selectById, selectManyByField, selectOneByField, selectOneWhereIn, selectOrderBy,
-                                   selectWhereNotNull, selectWhereNull, update, updateFieldsBy)
+                                   selectWhereNotNull, selectWhereNull, update, updateFieldsBy, insertMany, insert)
 import Database.PostgreSQL.Entity.DBT (QueryNature (..), query, query_)
 import Database.PostgreSQL.Entity.Internal.BlogPost (Author (..), AuthorId (..), BlogPost (..), BlogPostId (..),
                                                      bulkInsertAuthors, bulkInsertBlogPosts, insertAuthor,
-                                                     insertBlogPost)
+                                                     insertBlogPost, UUIDList)
 import Database.PostgreSQL.Entity.Internal.QQ (field)
-import Database.PostgreSQL.Simple (Connection, Only (Only))
+import Database.PostgreSQL.Simple (Connection, Only (Only), FromRow, ToRow)
 import Database.PostgreSQL.Simple.Migration (MigrationCommand (MigrationDirectory, MigrationInitialization),
                                              runMigrations)
 import Database.PostgreSQL.Transact (DBT)
 
 import qualified Data.Set as S
 import qualified Data.Set as Set
 import Data.Vector (Vector)
-import Database.PostgreSQL.Entity.Types
 import Optics.Core
 import Test.Tasty
 import Test.Tasty.HUnit
 import Utils
 import qualified Utils as U
+import Data.UUID (UUID)
+import GHC.Generics (Generic)
+import qualified Hedgehog.Gen as H
+import qualified Hedgehog.Range as Range
 
 spec :: TestM TestTree
 spec = testThese "Entity Tests"
@@ -45,6 +49,7 @@ spec = testThese "Entity Tests"
   , testThis "SELECT ORDER BY yields the appropriate results" testSelectOrderBy
   , testThis "select blog posts by author's name" selectBlogpostsByAuthorName
   , testThis "Insert many blog posts" insertManyBlogPosts
+  , testThis "Insert many faulty entities" insertManyFaultyEntities
   ]
 
 selectBlogPostByTitle :: TestM ()
@@ -187,10 +192,20 @@ insertManyBlogPosts = do
   author2 <- randomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"}
   void $ liftDB $ bulkInsertAuthors [author1, author2]
 
-  -- author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"}
-  -- blogPost1 <- randomBlogPost randomBlogPostTemplate{ generateAuthorId = pure (author ^. #authorId) }
-  -- blogPost2 <- randomBlogPost randomBlogPostTemplate{ generateAuthorId = pure (author ^. #authorId) }
+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"}
+  blogPost1 <- randomBlogPost randomBlogPostTemplate{ generateAuthorId = pure (author ^. #authorId) }
+  blogPost2 <- randomBlogPost randomBlogPostTemplate{ generateAuthorId = pure (author ^. #authorId) }
+
+  void $ liftDB $ bulkInsertBlogPosts [blogPost1, blogPost2]
+  result <- liftDB $ joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] (author ^. #name)
+  U.assertEqual (S.fromList [blogPost1, blogPost2]) (S.fromList $ V.toList result)
+
+insertManyFaultyEntities :: TestM ()
+insertManyFaultyEntities = do
+  entity1 <- H.sample genFaultyEntity
+  entity2 <- H.sample genFaultyEntity
+  entity3 <- H.sample genFaultyEntity
+  entity4 <- H.sample genFaultyEntity
 
-  -- void $ liftDB $ bulkInsertBlogPosts [blogPost1, blogPost2]
-  -- result <- liftDB $ joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] (author ^. #name)
-  -- U.assertEqual (S.fromList [blogPost1, blogPost2]) (S.fromList $ V.toList result)
+  liftDB $ insert @FaultyEntity entity1
+  liftDB $ insertMany @FaultyEntity [entity2, entity3, entity4]

test/Main.hs

@@ -8,6 +8,8 @@ import qualified GenericsSpec
 import Optics.Core
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import Utils
+import Database.Postgres.Temp (Config(..))
+import Database.Postgres.Temp.Internal
 
 main :: IO ()
 main = do
@@ -24,10 +26,21 @@ specs =
 
 getTestEnvironment :: IO TestEnv
 getTestEnvironment = do
-  eitherDb <- Postgres.Temp.start
+  eitherDb <- Postgres.Temp.startConfig customConfig
   case eitherDb of
       Right db -> do
         pool <- createPool (PG.connectPostgreSQL $ Postgres.Temp.toConnectionString db)
                            PG.close 1 100000000 50
         pure TestEnv{..}
       Left _ -> error "meh"
+
+
+
+customConfig :: Config
+customConfig = verboseConfig
+  { postgresConfigFile = verbosePostgresConfig <>
+      [  ("log_connections", "off")
+       , ("log_disconnections", "off")
+      ]
+
+   }

test/Utils.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Use newtype instead of data" #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedLists #-}
 module Utils where
 
 import Control.Exception.Safe
@@ -13,10 +13,10 @@ import Data.Text (Text)
 import Data.Time
 import Data.UUID (UUID)
 import qualified Data.UUID as UUID
-import qualified Data.Vector as V
+import qualified Data.Vector as Vector
 import Data.Word
 import Database.PostgreSQL.Entity.DBT (withPool)
-import Database.PostgreSQL.Simple (Connection)
+import Database.PostgreSQL.Simple (Connection, FromRow, ToRow)
 import Database.PostgreSQL.Transact
 import GHC.Generics
 import Hedgehog (MonadGen (..))
@@ -29,6 +29,8 @@ import qualified Test.Tasty.HUnit as Test
 
 import Database.PostgreSQL.Entity.Internal.BlogPost
 import Database.PostgreSQL.Simple.Migration
+import Data.Vector (Vector)
+import Database.PostgreSQL.Entity.Types
 
 newtype TestM (a :: Type)
   = TestM { getTestM :: ReaderT TestEnv IO a }
@@ -82,7 +84,7 @@ genUUID = UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32
     genWord32 = H.word32 (Range.constant minBound maxBound)
 
 genUUIDList :: MonadGen m => m UUIDList
-genUUIDList = UUIDList . V.fromList <$> H.list (Range.linear 1 10) genUUID
+genUUIDList = UUIDList . Vector.fromList <$> H.list (Range.linear 1 10) genUUID
 
 genUTCTime :: MonadGen m => m UTCTime
 genUTCTime = do
@@ -189,3 +191,38 @@ instantiateRandomBlogPost RandomBlogPostTemplate{..} = do
   let blogPost = BlogPost{..}
   insertBlogPost blogPost
   pure blogPost
+
+-- 
+
+data FaultyEntity = FaultyEntity
+  { field1 :: Vector UUID
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (FromRow, ToRow)
+
+instance Entity FaultyEntity where
+  tableName  = "faulty_entity"
+  primaryKey = [field| field1 |]
+  fields = [ [field| field1 :: uuid[] |] ]
+
+genFaultyEntity :: MonadGen m => m FaultyEntity
+genFaultyEntity = do
+  field1 <- Vector.fromList <$> H.list (Range.linear 1 3) genUUID
+  pure FaultyEntity{..}
+
+data GoodEntity = GoodEntity
+  { field2 :: UUIDList
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (FromRow, ToRow)
+
+instance Entity GoodEntity where
+  tableName  = "faulty_entity"
+  primaryKey = [field| field2 |]
+  fields = [ [field| field2 |] ]
+
+genGoodEntity :: MonadGen m => m GoodEntity
+genGoodEntity = do
+  field2 <- genUUIDList
+  pure GoodEntity{..}
+

test/migrations/20210228194538_blogpost.sql

@@ -15,3 +15,8 @@ create table blogposts (
     foreign key(author_id)
       references authors(author_id)
 );
+
+create table faulty_entity (
+  field1 uuid[] primary key,
+  field2 uuid[]
+);