a19d51e · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

arrays

a19d51eEitan Chatav9 years ago

squeal-postgresql/exe/Example.hs+16−11

compare with dev

unifiedsplit

@@ -4,6 +4,7 @@

4 , FlexibleContexts

5 , OverloadedLabels

6 , OverloadedStrings

7+ , OverloadedLists

7 , TypeApplications

8 , TypeApplications

8 , TypeOperators

9 , TypeOperators

9#-}

10#-}

@@ -12,9 +13,10 @@ module Main (main, main2) where

13import Control.Monad (void)

14import Control.Monad (void)

14import Control.Monad.Base (liftBase, MonadBase)

15import Control.Monad.Base (liftBase, MonadBase)

15−import Data.Int (Int32)

16+import Data.Int (Int16, Int32)

16import Data.Monoid ((<>))

17import Data.Monoid ((<>))

17import Data.Text (Text)

18import Data.Text (Text)

19+import Data.Vector (Vector)

19import Squeal.PostgreSQL

21import Squeal.PostgreSQL

@@ -27,6 +29,7 @@ type Schema =

27 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

29 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

28 '[ "id" ::: 'Def :=> 'NotNull 'PGint4

30 '[ "id" ::: 'Def :=> 'NotNull 'PGint4

29 , "name" ::: 'NoDef :=> 'NotNull 'PGtext

31 , "name" ::: 'NoDef :=> 'NotNull 'PGtext

32+ , "vec" ::: 'NoDef :=> 'NotNull ('PGarray 'PGint2)

30 ]

33 ]

31 , "emails" :::

34 , "emails" :::

32 '[ "pk_emails" ::: 'PrimaryKey '["id"]

35 '[ "pk_emails" ::: 'PrimaryKey '["id"]

@@ -42,7 +45,8 @@ setup :: Definition '[] Schema

42setup =

45setup =

43 createTable #users

46 createTable #users

44 ( serial `As` #id :*

47 ( serial `As` #id :*

45− (text & notNull) `As` #name :* Nil )

48+ (text & notNull) `As` #name :*

49+ (array int2 & notNull) `As` #vec :* Nil )

46 ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )

50 ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )

47 >>>

51 >>>

48 createTable #emails

52 createTable #emails

@@ -56,10 +60,10 @@ setup =

56teardown :: Definition Schema '[]

60teardown :: Definition Schema '[]

57teardown = dropTable #emails >>> dropTable #users

61teardown = dropTable #emails >>> dropTable #users

59−insertUser :: Manipulation Schema '[ 'NotNull 'PGtext]

63+insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGarray 'PGint2)]

60 '[ "fromOnly" ::: 'NotNull 'PGint4 ]

64 '[ "fromOnly" ::: 'NotNull 'PGint4 ]

61insertUser = insertRows #users

65insertUser = insertRows #users

62− (Default `As` #id :* Set (param @1) `As` #name :* Nil) []

66+ (Default `As` #id :* Set (param @1) `As` #name :* Set (param @2) `As` #vec :* Nil) []

63 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))

67 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))

65insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]

69insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]

@@ -71,29 +75,30 @@ insertEmail = insertRows #emails

72getUsers :: Query Schema '[]

76getUsers :: Query Schema '[]

73 '[ "userName" ::: 'NotNull 'PGtext

77 '[ "userName" ::: 'NotNull 'PGtext

74− , "userEmail" ::: 'Null 'PGtext ]

78+ , "userEmail" ::: 'Null 'PGtext

79+ , "userVec" ::: 'NotNull ('PGarray 'PGint2)]

75getUsers = select

80getUsers = select

76− (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)

81+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* #u ! #vec `As` #userVec :* Nil)

77 ( from (Table (#users `As` #u)

82 ( from (Table (#users `As` #u)

78 & InnerJoin (Table (#emails `As` #e))

83 & InnerJoin (Table (#emails `As` #e))

79 (#u ! #id .== #e ! #user_id)) )

84 (#u ! #id .== #e ! #user_id)) )

81−data User = User { userName :: Text, userEmail :: Maybe Text }

86+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }

82 deriving (Show, GHC.Generic)

87 deriving (Show, GHC.Generic)

83instance SOP.Generic User

88instance SOP.Generic User

84instance SOP.HasDatatypeInfo User

89instance SOP.HasDatatypeInfo User

86users :: [User]

91users :: [User]

87users =

92users =

88− [ User "Alice" (Just "alice@gmail.com")

93+ [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]

89− , User "Bob" Nothing

94+ , User "Bob" Nothing [Just 2, Nothing]

90− , User "Carole" (Just "carole@hotmail.com")

95+ , User "Carole" (Just "carole@hotmail.com") [Just 3]

91 ]

96 ]

93session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()

98session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()

94session = do

99session = do

95 liftBase $ Char8.putStrLn "manipulating"

100 liftBase $ Char8.putStrLn "manipulating"

96− idResults <- traversePrepared insertUser (Only . userName <$> users)

101+ idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])

97 ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults

102 ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults

98 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))

103 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))

99 liftBase $ Char8.putStrLn "querying"

104 liftBase $ Char8.putStrLn "querying"

squeal-postgresql/squeal-postgresql.cabal+1

@@ -50,6 +50,7 @@ library

50 , transformers >= 0.5.2.0 && < 1

51 , transformers-base >= 0.4.4 && < 1

52 , uuid >= 1.3.13 && < 2

53+ , vector

54test-suite squeal-postgresql-doctest

55test-suite squeal-postgresql-doctest

55 default-language: Haskell2010

56 default-language: Haskell2010

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+14

@@ -49,6 +49,7 @@ import Data.Kind

49import Data.Scientific

50import Data.Time

51import Data.UUID

52+import Data.Vector (Vector)

52import Data.Word

53import Data.Word

53import Generics.SOP

54import Generics.SOP

54import GHC.TypeLits

55import GHC.TypeLits

@@ -58,6 +59,7 @@ import qualified Data.ByteString.Lazy as Lazy

58import qualified Data.ByteString as Strict hiding (unpack)

59import qualified Data.ByteString as Strict hiding (unpack)

59import qualified Data.Text.Lazy as Lazy

60import qualified Data.Text.Lazy as Lazy

60import qualified Data.Text as Strict

61import qualified Data.Text as Strict

62+import qualified Data.Vector as Vector

61import qualified GHC.Generics as GHC

63import qualified GHC.Generics as GHC

62import qualified PostgreSQL.Binary.Decoding as Decoding

64import qualified PostgreSQL.Binary.Decoding as Decoding

63import qualified PostgreSQL.Binary.Encoding as Encoding

65import qualified PostgreSQL.Binary.Encoding as Encoding

@@ -113,6 +115,10 @@ instance ToParam UTCTime 'PGtimestamptz where

113instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int

115instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int

114instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast

116instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast

115instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast

117instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast

118+instance (Oid pg, ToParam x pg)

119+ => ToParam (Vector (Maybe x)) ('PGarray pg) where

120+ toParam = K . Encoding.nullableArray_vector

121+ (oid (Proxy @pg)) (unK . toParam @x @pg)

116

122

117-- | A `ToColumnParam` constraint lifts the `ToParam` encoding

123-- | A `ToColumnParam` constraint lifts the `ToParam` encoding

118-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should

124-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should

@@ -187,6 +193,14 @@ instance FromValue 'PGinterval DiffTime where

187 fromValue _ = Decoding.interval_int

193 fromValue _ = Decoding.interval_int

188instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast

194instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast

189instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast

195instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast

196+instance FromValue pg y => FromValue ('PGarray pg) (Vector (Maybe y)) where

197+ fromValue _ = Decoding.array

198+ (Decoding.dimensionArray Vector.replicateM

199+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))

200+instance FromValue pg y => FromValue ('PGarrayN n pg) (Vector (Maybe y)) where

201+ fromValue _ = Decoding.array

202+ (Decoding.dimensionArray Vector.replicateM

203+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))

190

204

191-- | A `FromColumnValue` constraint lifts the `FromValue` parser

205-- | A `FromColumnValue` constraint lifts the `FromValue` parser

192-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,

206-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+33−21

@@ -47,7 +47,9 @@ module Squeal.PostgreSQL.Expression

47 , isn'tNull

48 , matchNull

49 , nullIf

50+ -- ** Arrays

51+ , array

50− -- ** Functions

52+ -- ** Functions

51 , unsafeBinaryOp

53 , unsafeBinaryOp

52 , unsafeUnaryOp

54 , unsafeUnaryOp

53 , unsafeFunction

55 , unsafeFunction

@@ -135,6 +137,8 @@ module Squeal.PostgreSQL.Expression

135 , inet

137 , inet

136 , json

138 , json

137 , jsonb

139 , jsonb

140+ , vararray

141+ , arrayN

138 , notNull

142 , notNull

139 , default_

143 , default_

140 -- * Re-export

144 -- * Re-export

@@ -211,26 +215,6 @@ instance (Has table tables columns, Has column columns ty)

211 table ! column = UnsafeExpression $

215 table ! column = UnsafeExpression $

212 renderAlias table <> "." <> renderAlias column

216 renderAlias table <> "." <> renderAlias column

213

217

214−-- | A `Column` is a witness to a `HasColumn` constraint. It's used

215−-- in `Squeel.PostgreSQL.Definition.unique` and other

216−-- `Squeel.PostgreSQL.Definition.TableConstraint`s to witness a

217−-- subcolumns relationship.

218−-- data Column

219−-- (columns :: RelationType)

220−-- (columnty :: (Symbol,NullityType))

221−-- where

222−-- Column

223−-- :: Has column columns ty

224−-- => Alias column

225−-- -> Column columns (column ::: ty)

226−-- deriving instance Show (Column columns columnty)

227−-- deriving instance Eq (Column columns columnty)

228−-- deriving instance Ord (Column columns columnty)

229−

230−-- -- | Render a `Column`.

231−-- renderColumn :: Column columns columnty -> ByteString

232−-- renderColumn (Column column) = renderAlias column

233−

234{- | A `GroupedBy` constraint indicates that a table qualified column is

218{- | A `GroupedBy` constraint indicates that a table qualified column is

235a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,

219a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,

236may be called in an output `Expression` without aggregating.

220may be called in an output `Expression` without aggregating.

@@ -360,6 +344,17 @@ nullIf

360nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

344nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

361 (renderExpression x <> ", " <> renderExpression y)

345 (renderExpression x <> ", " <> renderExpression y)

362

346

347+array

348+ :: [Expression tables grouping params ('Null ty)]

349+ -> Expression tables grouping params (nullity ('PGarray ty))

350+array xs = UnsafeExpression $

351+ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"

352+

353+instance Monoid

354+ (Expression tables grouping params (nullity ('PGarray ty))) where

355+ mempty = array []

356+ mappend = unsafeBinaryOp "||"

357+

363-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]

358-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]

364-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"

359-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"

365greatest

360greatest

@@ -1163,6 +1158,19 @@ json = UnsafeTypeExpression "json"

1163-- | binary JSON data, decomposed

1158-- | binary JSON data, decomposed

1164jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb)

1159jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb)

1165jsonb = UnsafeTypeExpression "jsonb"

1160jsonb = UnsafeTypeExpression "jsonb"

1161+-- | variable length array

1162+vararray

1163+ :: TypeExpression ('NoDef :=> 'Null pg)

1164+ -> TypeExpression ('NoDef :=> 'Null ('PGarray pg))

1165+vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

1166+-- | fixed length array

1167+arrayN

1168+ :: KnownNat n

1169+ => proxy n

1170+ -> TypeExpression ('NoDef :=> 'Null pg)

1171+ -> TypeExpression ('NoDef :=> 'Null ('PGarrayN n pg))

1172+arrayN p ty = UnsafeTypeExpression $

1173+ renderTypeExpression ty <> "[" <> renderNat p <> "]"

1166

1174

1167-- | used in `createTable` commands as a column constraint to ensure

1175-- | used in `createTable` commands as a column constraint to ensure

1168-- @NULL@ is not present

1176-- @NULL@ is not present

@@ -1204,3 +1212,7 @@ instance PGTyped 'PGinterval where pgtype = interval

1204instance PGTyped 'PGuuid where pgtype = uuid

1212instance PGTyped 'PGuuid where pgtype = uuid

1205instance PGTyped 'PGjson where pgtype = json

1213instance PGTyped 'PGjson where pgtype = json

1206instance PGTyped 'PGjsonb where pgtype = jsonb

1214instance PGTyped 'PGjsonb where pgtype = jsonb

1215+instance PGTyped ty => PGTyped ('PGarray ty) where

1216+ pgtype = vararray (pgtype @ty)

1217+instance (KnownNat n, PGTyped ty) => PGTyped ('PGarrayN n ty) where

1218+ pgtype = arrayN (Proxy @n) (pgtype @ty)

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+27

@@ -35,6 +35,7 @@ Embedding of PostgreSQL type and alias system

35module Squeal.PostgreSQL.Schema

36 ( -- * Kinds

37 PGType (..)

38+ , Oid (..)

38 , NullityType (..)

39 , NullityType (..)

39 , ColumnType

40 , ColumnType

40 , ColumnsType

41 , ColumnsType

@@ -89,6 +90,7 @@ import Control.DeepSeq

89import Data.ByteString

90import Data.ByteString

90import Data.Monoid

91import Data.Monoid

91import Data.String

92import Data.String

93+import Data.Word

92import Generics.SOP (AllZip)

94import Generics.SOP (AllZip)

93import GHC.Generics (Generic)

95import GHC.Generics (Generic)

94import GHC.Exts

96import GHC.Exts

@@ -120,8 +122,33 @@ data PGType

120 | PGinet -- ^ IPv4 or IPv6 host address

122 | PGinet -- ^ IPv4 or IPv6 host address

121 | PGjson -- ^ textual JSON data

123 | PGjson -- ^ textual JSON data

122 | PGjsonb -- ^ binary JSON data, decomposed

124 | PGjsonb -- ^ binary JSON data, decomposed

125+ | PGarray PGType -- ^ variable length array

126+ | PGarrayN Nat PGType -- ^ fixed length array

123 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

127 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

124

128

129+class Oid (ty :: PGType) where oid :: proxy ty -> Word32

130+instance Oid 'PGbool where oid _ = 16

131+instance Oid 'PGint2 where oid _ = 21

132+instance Oid 'PGint4 where oid _ = 23

133+instance Oid 'PGint8 where oid _ = 20

134+instance Oid 'PGnumeric where oid _ = 1700

135+instance Oid 'PGfloat4 where oid _ = 700

136+instance Oid 'PGfloat8 where oid _ = 701

137+instance Oid ('PGchar n) where oid _ = 18

138+instance Oid ('PGvarchar n) where oid _ = 1043

139+instance Oid 'PGtext where oid _ = 25

140+instance Oid 'PGbytea where oid _ = 17

141+instance Oid 'PGtimestamp where oid _ = 1114

142+instance Oid 'PGtimestamptz where oid _ = 1184

143+instance Oid 'PGdate where oid _ = 1082

144+instance Oid 'PGtime where oid _ = 1083

145+instance Oid 'PGtimetz where oid _ = 1266

146+instance Oid 'PGinterval where oid _ = 1186

147+instance Oid 'PGuuid where oid _ = 2950

148+instance Oid 'PGinet where oid _ = 869

149+instance Oid 'PGjson where oid _ = 114

150+instance Oid 'PGjsonb where oid _ = 3802

151+

125-- | `NullityType` encodes the potential presence or definite absence of a

152-- | `NullityType` encodes the potential presence or definite absence of a

126-- @NULL@ allowing operations which are sensitive to such to be well typed.

153-- @NULL@ allowing operations which are sensitive to such to be well typed.

127data NullityType

154data NullityType