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

@@ -17,10 +17,13 @@
 --  The models described in this module are used throughout the library's tests and docspecs.
 module Database.PostgreSQL.Entity.Internal.BlogPost where
 
+import Data.ByteString.Builder (byteString, char8)
+import qualified Data.List as List
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Data.UUID (UUID)
 import Data.Vector (Vector)
+import qualified Data.Vector as Vector
 import Database.PostgreSQL.Simple.FromField (FromField)
 import Database.PostgreSQL.Simple.FromRow (FromRow (..))
 import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..))
@@ -30,9 +33,6 @@ 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

@@ -29,7 +29,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

@@ -13,6 +13,8 @@ import qualified Data.Vector as V
 import Database.PostgreSQL.Entity
   ( delete
   , deleteByField
+  , insert
+  , insertMany
   , joinSelectOneByField
   , selectById
   , selectManyByField
@@ -32,13 +34,15 @@ import Database.PostgreSQL.Entity.Internal.BlogPost
   , AuthorId (..)
   , BlogPost (..)
   , BlogPostId (..)
+  , UUIDList
   , bulkInsertAuthors
   , bulkInsertBlogPosts
   , insertAuthor
   , insertBlogPost
   )
 import Database.PostgreSQL.Entity.Internal.QQ (field)
-import Database.PostgreSQL.Simple (Connection, Only (Only))
+import Database.PostgreSQL.Entity.Types
+import Database.PostgreSQL.Simple (Connection, FromRow, Only (Only), ToRow)
 import Database.PostgreSQL.Simple.Migration
   ( MigrationCommand (MigrationDirectory, MigrationInitialization)
   , runMigrations
@@ -47,8 +51,11 @@ import Database.PostgreSQL.Transact (DBT)
 
 import qualified Data.Set as S
 import qualified Data.Set as Set
+import Data.UUID (UUID)
 import Data.Vector (Vector)
-import Database.PostgreSQL.Entity.Types
+import GHC.Generics (Generic)
+import qualified Hedgehog.Gen as H
+import qualified Hedgehog.Range as Range
 import Optics.Core
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -69,6 +76,7 @@ spec =
     , 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 ()
@@ -241,10 +249,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

@@ -2,7 +2,9 @@ module Main where
 
 import Data.Pool (createPool, withResource)
 import qualified Database.PostgreSQL.Simple as PG
+import Database.Postgres.Temp (Config (..))
 import qualified Database.Postgres.Temp as Postgres.Temp
+import Database.Postgres.Temp.Internal
 import qualified EntitySpec
 import qualified GenericsSpec
 import Optics.Core
@@ -24,7 +26,7 @@ specs =
 
 getTestEnvironment :: IO TestEnv
 getTestEnvironment = do
-  eitherDb <- Postgres.Temp.start
+  eitherDb <- Postgres.Temp.startConfig customConfig
   case eitherDb of
     Right db -> do
       pool <-
@@ -36,3 +38,13 @@ getTestEnvironment = do
           50
       pure TestEnv{..}
     Left _ -> error "meh"
+
+customConfig :: Config
+customConfig =
+  verboseConfig
+    { postgresConfigFile =
+        verbosePostgresConfig
+          <> [ ("log_connections", "off")
+             , ("log_disconnections", "off")
+             ]
+    }

test/Utils.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
-{-# HLINT ignore "Use newtype instead of data" #-}
 module Utils where
 
 import Control.Exception.Safe
@@ -14,10 +14,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 (..))
@@ -28,7 +28,9 @@ import Test.Tasty (TestTree)
 import qualified Test.Tasty as Test
 import qualified Test.Tasty.HUnit as Test
 
+import Data.Vector (Vector)
 import Database.PostgreSQL.Entity.Internal.BlogPost
+import Database.PostgreSQL.Entity.Types
 import Database.PostgreSQL.Simple.Migration
 
 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
@@ -191,3 +193,37 @@ 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[]
+);