bb711e6 · squeal · git.iko.soy

squeal-postgresql/squeal-postgresql.cabal+24−8

compare with dev

unifiedsplit

@@ -35,6 +35,7 @@ library

35 Squeal.PostgreSQL.Expression.Math

36 Squeal.PostgreSQL.Expression.Null

37 Squeal.PostgreSQL.Expression.Parameter

38+ Squeal.PostgreSQL.Expression.Range

38 Squeal.PostgreSQL.Expression.SetOf

39 Squeal.PostgreSQL.Expression.SetOf

39 Squeal.PostgreSQL.Expression.Sort

40 Squeal.PostgreSQL.Expression.Sort

40 Squeal.PostgreSQL.Expression.Subquery

41 Squeal.PostgreSQL.Expression.Subquery

@@ -79,35 +80,50 @@ library

79 , uuid-types >= 1.0.3

80 , uuid-types >= 1.0.3

80 , vector >= 0.12.0.1

81 , vector >= 0.12.0.1

81

82

82−test-suite squeal-postgresql-doctest

83+test-suite doctest

83 default-language: Haskell2010

84 default-language: Haskell2010

84 type: exitcode-stdio-1.0

85 type: exitcode-stdio-1.0

85 hs-source-dirs: test

86 hs-source-dirs: test

86 ghc-options: -Wall

87 ghc-options: -Wall

87− main-is: DocTest.hs

88+ main-is: Doc.hs

88 build-depends:

89 build-depends:

89 base >= 4.10.0.0

90 base >= 4.10.0.0

90 , doctest >= 0.11.4

91 , doctest >= 0.11.4

92+ , squeal-postgresql

93+

94+test-suite properties

95+ default-language: Haskell2010

96+ type: exitcode-stdio-1.0

97+ hs-source-dirs: test

98+ ghc-options: -Wall

99+ main-is: Property.hs

100+ build-depends:

101+ base >= 4.10.0.0

102+ , bytestring >= 0.10.8.2

103+ , hedgehog >= 1.0

104+ , mtl >= 2.2.2

105+ , scientific >= 0.3.5.3

106+ , squeal-postgresql

107+ , time >= 1.8.0.2

91

108

92−test-suite squeal-postgresql-specs

109+test-suite spec

93 default-language: Haskell2010

110 default-language: Haskell2010

94 type: exitcode-stdio-1.0

111 type: exitcode-stdio-1.0

95− hs-source-dirs: test/Specs

112+ hs-source-dirs: test

96 ghc-options: -Wall

113 ghc-options: -Wall

97− main-is: Specs.hs

114+ main-is: Spec.hs

98− other-modules: ExceptionHandling

99 build-depends:

115 build-depends:

100 base >= 4.10.0.0

116 base >= 4.10.0.0

101 , async >= 2.2.2

117 , async >= 2.2.2

102 , bytestring >= 0.10.8.2

118 , bytestring >= 0.10.8.2

103 , generics-sop >= 0.3.1.0

119 , generics-sop >= 0.3.1.0

104 , hspec >= 2.4.8

120 , hspec >= 2.4.8

121+ , mtl >= 2.2.2

105 , squeal-postgresql

122 , squeal-postgresql

106 , text >= 1.2.2.2

123 , text >= 1.2.2.2

107− , transformers >= 0.5.2.0

108 , vector >= 0.12.0.1

124 , vector >= 0.12.0.1

109

125

110−executable squeal-postgresql-example

126+executable example

111 default-language: Haskell2010

127 default-language: Haskell2010

112 hs-source-dirs: exe

128 hs-source-dirs: exe

113 ghc-options: -Wall

129 ghc-options: -Wall

squeal-postgresql/src/Squeal/PostgreSQL.hs+1

@@ -205,6 +205,7 @@ import Squeal.PostgreSQL.Expression.Logic as X

205import Squeal.PostgreSQL.Expression.Math as X

206import Squeal.PostgreSQL.Expression.Null as X

207import Squeal.PostgreSQL.Expression.Parameter as X

208+import Squeal.PostgreSQL.Expression.Range as X

208import Squeal.PostgreSQL.Expression.SetOf as X

209import Squeal.PostgreSQL.Expression.SetOf as X

209import Squeal.PostgreSQL.Expression.Sort as X

210import Squeal.PostgreSQL.Expression.Sort as X

210import Squeal.PostgreSQL.Expression.Subquery as X

211import Squeal.PostgreSQL.Expression.Subquery as X

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+11−1

@@ -45,6 +45,7 @@ module Squeal.PostgreSQL.Definition

45 , createTypeCompositeFrom

46 , FieldTyped (..)

47 , createDomain

48+ , createTypeRange

48 , TableConstraintExpression (..)

49 , TableConstraintExpression (..)

49 , check

50 , check

50 , unique

51 , unique

@@ -1032,7 +1033,7 @@ CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL))

1032createDomain

1033createDomain

1033 :: (Has sch schemas schema, KnownSymbol dom)

1034 :: (Has sch schemas schema, KnownSymbol dom)

1034 => QualifiedAlias sch dom

1035 => QualifiedAlias sch dom

1035− -> (forall nullity. TypeExpression schemas (nullity ty))

1036+ -> (forall null. TypeExpression schemas (null ty))

1036 -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])

1037 -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])

1037 -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)

1038 -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)

1038createDomain dom ty condition =

1039createDomain dom ty condition =

@@ -1040,6 +1041,15 @@ createDomain dom ty condition =

1040 <+> "AS" <+> renderTypeExpression ty

1041 <+> "AS" <+> renderTypeExpression ty

1041 <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"

1042 <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"

1042

1043

1044+createTypeRange

1045+ :: (Has sch schemas schema, KnownSymbol range)

1046+ => QualifiedAlias sch range

1047+ -> (forall null. TypeExpression schemas (null ty))

1048+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)

1049+createTypeRange range ty = UnsafeDefinition $

1050+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>

1051+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty)

1052+

1043-- | Lift `PGTyped` to a field

1053-- | Lift `PGTyped` to a field

1044class FieldTyped schemas ty where

1054class FieldTyped schemas ty where

1045 fieldtype :: Aliased (TypeExpression schemas) ty

1055 fieldtype :: Aliased (TypeExpression schemas) ty

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+11−3

@@ -45,6 +45,7 @@ module Squeal.PostgreSQL.Expression

45 , FunctionN

46 , unsafeFunctionN

47 , PGSubset (..)

48+ , PGIntersect (..)

48 -- * Re-export

49 -- * Re-export

49 , (&)

50 , (&)

50 , K (..)

51 , K (..)

@@ -353,14 +354,21 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating

353 atanh x = log ((1 + x) / (1 - x)) / 2

354 atanh x = log ((1 + x) / (1 - x)) / 2

354

355

355-- | Contained by operators

356-- | Contained by operators

356−class PGSubset container where

357+class PGSubset ty where

357− (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)

358+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

358 (@>) = unsafeBinaryOp "@>"

359 (@>) = unsafeBinaryOp "@>"

359− (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)

360+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

360 (<@) = unsafeBinaryOp "<@"

361 (<@) = unsafeBinaryOp "<@"

361instance PGSubset 'PGjsonb

362instance PGSubset 'PGjsonb

362instance PGSubset 'PGtsquery

363instance PGSubset 'PGtsquery

363instance PGSubset ('PGvararray ty)

364instance PGSubset ('PGvararray ty)

365+instance PGSubset ('PGrange ty)

366+

367+class PGIntersect ty where

368+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

369+ (@&&) = unsafeBinaryOp "&&"

370+instance PGIntersect ('PGvararray ty)

371+instance PGIntersect ('PGrange ty)

364

372

365instance IsString

373instance IsString

366 (Expression outer commons grp schemas params from (null 'PGtext)) where

374 (Expression outer commons grp schemas params from (null 'PGtext)) where

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsnew file+231

@@ -0,0 +1,231 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Range

3+Description: range types and functions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

7+

8+Range types and functions

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , DataKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DeriveFoldable

17+ , DerivingStrategies

18+ , DeriveTraversable

19+ , FlexibleContexts

20+ , FlexibleInstances

21+ , LambdaCase

22+ , MultiParamTypeClasses

23+ , OverloadedLabels

24+ , OverloadedStrings

25+ , PatternSynonyms

26+ , RankNTypes

27+ , ScopedTypeVariables

28+ , TypeApplications

29+ , TypeFamilies

30+ , TypeOperators

31+ , UndecidableInstances

32+#-}

33+

34+module Squeal.PostgreSQL.Expression.Range

35+ ( range

36+ , Range (..)

37+ , (<=..<=), (<..<), (<=..<), (<..<=)

38+ , moreThan, atLeast, lessThan, atMost

39+ , singleton, whole

40+ , Bound (..)

41+ , (.<@)

42+ , (@>.)

43+ , (<<@)

44+ , (@>>)

45+ , (&<)

46+ , (&>)

47+ , (-|-)

48+ , (@+)

49+ , (@*)

50+ , (@-)

51+ , lowerBound

52+ , upperBound

53+ , isEmpty

54+ , lowerInc

55+ , lowerInf

56+ , upperInc

57+ , upperInf

58+ , rangeMerge

59+ ) where

60+

61+import BinaryParser

62+import ByteString.StrictBuilder

63+import Data.Bits

64+import qualified GHC.Generics as GHC

65+import qualified Generics.SOP as SOP

66+import qualified PostgreSQL.Binary.Decoding as Decoding

67+

68+import Squeal.PostgreSQL.Binary

69+import Squeal.PostgreSQL.Expression

70+import Squeal.PostgreSQL.Expression.Type hiding (bool)

71+import Squeal.PostgreSQL.PG

72+import Squeal.PostgreSQL.Render

73+import Squeal.PostgreSQL.Schema

74+

75+-- $setup

76+-- >>> import Squeal.PostgreSQL

77+

78+-- | Construct a `range`

79+--

80+-- >>> printSQL $ range tstzrange (atLeast now)

81+-- tstzrange(now(), NULL, '[)')

82+-- >>> printSQL $ range numrange (0 <=..< 2*pi)

83+-- numrange(0, (2 * pi()), '[)')

84+-- >>> printSQL $ range int4range Empty

85+-- ('empty' :: int4range)

86+range

87+ :: TypeExpression schemas (null ('PGrange ty))

88+ -> Range (Expression outer commons grp schemas params from ('NotNull ty))

89+ -> Expression outer commons grp schemas params from (null ('PGrange ty))

90+range ty = \case

91+ Empty -> UnsafeExpression $ parenthesized

92+ (emp <+> "::" <+> renderSQL ty)

93+ NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized

94+ (commaSeparated (args l u))

95+ where

96+ emp = singleQuote <> "empty" <> singleQuote

97+ args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]

98+ singleQuote = "\'"

99+ arg = \case

100+ Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x

101+ bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("

102+ ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"

103+

104+data Bound x = Infinite | Closed x | Open x

105+ deriving

106+ ( Eq, Ord, Show, Read, GHC.Generic

107+ , Functor, Foldable, Traversable )

108+

109+data Range x = Empty | NonEmpty (Bound x) (Bound x)

110+ deriving

111+ ( Eq, Ord, Show, Read, GHC.Generic

112+ , Functor, Foldable, Traversable )

113+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

114+type instance PG (Range x) = 'PGrange (PG x)

115+instance ToParam x pg => ToParam (Range x) ('PGrange pg) where

116+ toParam rng = K $

117+ word8 (setFlags rng 0) <>

118+ case rng of

119+ Empty -> mempty

120+ NonEmpty lower upper -> putBound lower <> putBound upper

121+ where

122+ putBound = \case

123+ Infinite -> mempty

124+ Closed value -> putValue (unK (toParam @x @pg value))

125+ Open value -> putValue (unK (toParam @x @pg value))

126+ putValue value = int32BE (fromIntegral (builderLength value)) <> value

127+ setFlags = \case

128+ Empty -> (`setBit` 0)

129+ NonEmpty lower upper ->

130+ setLowerFlags lower . setUpperFlags upper

131+ setLowerFlags = \case

132+ Infinite -> (`setBit` 3)

133+ Closed _ -> (`setBit` 1)

134+ Open _ -> id

135+ setUpperFlags = \case

136+ Infinite -> (`setBit` 4)

137+ Closed _ -> (`setBit` 2)

138+ Open _ -> id

139+instance FromValue pg y => FromValue ('PGrange pg) (Range y) where

140+ fromValue = do

141+ flag <- byte

142+ if testBit flag 0 then return Empty else do

143+ lower <-

144+ if testBit flag 3

145+ then return Infinite

146+ else do

147+ len <- sized 4 Decoding.int

148+ l <- sized len (fromValue @pg)

149+ return $ if testBit flag 1 then Closed l else Open l

150+ upper <-

151+ if testBit flag 4

152+ then return Infinite

153+ else do

154+ len <- sized 4 Decoding.int

155+ l <- sized len (fromValue @pg)

156+ return $ if testBit flag 2 then Closed l else Open l

157+ return $ NonEmpty lower upper

158+

159+(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x

160+infix 4 <=..<=, <..<, <=..<, <..<=

161+x <=..<= y = NonEmpty (Closed x) (Closed y)

162+x <..< y = NonEmpty (Open x) (Open y)

163+x <=..< y = NonEmpty (Closed x) (Open y)

164+x <..<= y = NonEmpty (Open x) (Closed y)

165+

166+moreThan, atLeast, lessThan, atMost :: x -> Range x

167+moreThan x = NonEmpty (Open x) Infinite

168+atLeast x = NonEmpty (Closed x) Infinite

169+lessThan x = NonEmpty Infinite (Open x)

170+atMost x = NonEmpty Infinite (Closed x)

171+

172+singleton :: x -> Range x

173+singleton x = x <=..<= x

174+

175+whole :: Range x

176+whole = NonEmpty Infinite Infinite

177+

178+(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)

179+(.<@) = unsafeBinaryOp "<@"

180+

181+(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)

182+(@>.) = unsafeBinaryOp "<@"

183+

184+(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

185+(<<@) = unsafeBinaryOp "<<"

186+

187+(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

188+(@>>) = unsafeBinaryOp ">>"

189+

190+(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

191+(&<) = unsafeBinaryOp "&<"

192+

193+(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

194+(&>) = unsafeBinaryOp "&>"

195+

196+(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

197+(-|-) = unsafeBinaryOp "-|-"

198+

199+(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

200+(@+) = unsafeBinaryOp "+"

201+

202+(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

203+(@*) = unsafeBinaryOp "*"

204+

205+(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

206+(@-) = unsafeBinaryOp "-"

207+

208+lowerBound :: null ('PGrange ty) :--> 'Null ty

209+lowerBound = unsafeFunction "lower"

210+

211+upperBound :: null ('PGrange ty) :--> 'Null ty

212+upperBound = unsafeFunction "upper"

213+

214+isEmpty :: null ('PGrange ty) :--> 'Null 'PGbool

215+isEmpty = unsafeFunction "isempty"

216+

217+lowerInc :: null ('PGrange ty) :--> 'Null 'PGbool

218+lowerInc = unsafeFunction "lower_inc"

219+

220+lowerInf :: null ('PGrange ty) :--> 'Null 'PGbool

221+lowerInf = unsafeFunction "lower_inf"

222+

223+upperInc :: null ('PGrange ty) :--> 'Null 'PGbool

224+upperInc = unsafeFunction "upper_inc"

225+

226+upperInf :: null ('PGrange ty) :--> 'Null 'PGbool

227+upperInf = unsafeFunction "upper_inf"

228+

229+rangeMerge :: FunctionN

230+ '[ null ('PGrange ty), null ('PGrange ty)] (null ('PGrange ty))

231+rangeMerge = unsafeFunctionN "range_merge"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+30−2

@@ -56,9 +56,11 @@ module Squeal.PostgreSQL.Expression.Type

56 , bytea

57 , timestamp

58 , timestampWithTimeZone

59+ , timestamptz

59 , date

60 , date

60 , time

61 , time

61 , timeWithTimeZone

62 , timeWithTimeZone

63+ , timetz

62 , interval

64 , interval

63 , uuid

65 , uuid

64 , inet

66 , inet

@@ -69,6 +71,12 @@ module Squeal.PostgreSQL.Expression.Type

69 , tsvector

71 , tsvector

70 , tsquery

72 , tsquery

71 , oid

73 , oid

74+ , int4range

75+ , int8range

76+ , numrange

77+ , tsrange

78+ , tstzrange

79+ , daterange

72 ) where

80 ) where

73

81

74import Control.DeepSeq

82import Control.DeepSeq

@@ -214,8 +222,9 @@ bytea = UnsafeTypeExpression "bytea"

214timestamp :: TypeExpression schemas (null 'PGtimestamp)

222timestamp :: TypeExpression schemas (null 'PGtimestamp)

215timestamp = UnsafeTypeExpression "timestamp"

223timestamp = UnsafeTypeExpression "timestamp"

216-- | date and time, including time zone

224-- | date and time, including time zone

217−timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)

225+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)

218timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

226timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

227+timestamptz = UnsafeTypeExpression "timestamptz"

219-- | calendar date (year, month, day)

228-- | calendar date (year, month, day)

220date :: TypeExpression schemas (null 'PGdate)

229date :: TypeExpression schemas (null 'PGdate)

221date = UnsafeTypeExpression "date"

230date = UnsafeTypeExpression "date"

@@ -223,8 +232,9 @@ date = UnsafeTypeExpression "date"

223time :: TypeExpression schemas (null 'PGtime)

232time :: TypeExpression schemas (null 'PGtime)

224time = UnsafeTypeExpression "time"

233time = UnsafeTypeExpression "time"

225-- | time of day, including time zone

234-- | time of day, including time zone

226−timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)

235+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)

227timeWithTimeZone = UnsafeTypeExpression "time with time zone"

236timeWithTimeZone = UnsafeTypeExpression "time with time zone"

237+timetz = UnsafeTypeExpression "timetz"

228-- | time span

238-- | time span

229interval :: TypeExpression schemas (null 'PGinterval)

239interval :: TypeExpression schemas (null 'PGinterval)

230interval = UnsafeTypeExpression "interval"

240interval = UnsafeTypeExpression "interval"

@@ -275,6 +285,24 @@ tsquery = UnsafeTypeExpression "tsquery"

275-- as primary keys for various system tables.

285-- as primary keys for various system tables.

276oid :: TypeExpression schemas (null 'PGoid)

286oid :: TypeExpression schemas (null 'PGoid)

277oid = UnsafeTypeExpression "oid"

287oid = UnsafeTypeExpression "oid"

288+-- | Range of integer

289+int4range :: TypeExpression schemas (null ('PGrange 'PGint4))

290+int4range = UnsafeTypeExpression "int4range"

291+-- | Range of bigint

292+int8range :: TypeExpression schemas (null ('PGrange 'PGint8))

293+int8range = UnsafeTypeExpression "int8range"

294+-- | Range of numeric

295+numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))

296+numrange = UnsafeTypeExpression "numrange"

297+-- | Range of timestamp without time zone

298+tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))

299+tsrange = UnsafeTypeExpression "tsrange"

300+-- | Range of timestamp with time zone

301+tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))

302+tstzrange = UnsafeTypeExpression "tstzrange"

303+-- | Range of date

304+daterange :: TypeExpression schemas (null ('PGrange 'PGdate))

305+daterange = UnsafeTypeExpression "daterange"

278

306

279-- | `pgtype` is a demoted version of a `PGType`

307-- | `pgtype` is a demoted version of a `PGType`

280class PGTyped schemas (ty :: NullityType) where

308class PGTyped schemas (ty :: NullityType) where

squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+1−1

@@ -22,8 +22,8 @@ Stability: experimental

22 , FunctionalDependencies

23 , GADTs

24 , LambdaCase

25− , OverloadedStrings

26 , MultiParamTypeClasses

25 , MultiParamTypeClasses

26+ , OverloadedStrings

27 , ScopedTypeVariables

28 , TypeApplications

29 , TypeFamilies

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−1

@@ -432,7 +432,7 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

432 Just prepResult -> okResult_ prepResult

433 results <- for list $ \ params -> do

434 let

435− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)

435+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

436 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

437 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

438 case resultMaybe of

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

@@ -134,6 +134,8 @@ data PGType

134 | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.

135 | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for

136 | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.

137+ | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.

138+ | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).

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

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

138

140

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

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

squeal-postgresql/test/DocTest.hs → squeal-postgresql/test/Doc.hsrenamed

The content is the same.

squeal-postgresql/test/Property.hsnew file+166

@@ -0,0 +1,166 @@

1+{-# LANGUAGE

2+ DataKinds

3+ , GADTs

4+ , LambdaCase

5+ , OverloadedLabels

6+ , OverloadedStrings

7+ , TypeApplications

8+ , TypeOperators

9+#-}

10+

11+module Main (main) where

12+

13+import Control.Monad.Trans

14+import Data.ByteString (ByteString)

15+import Data.ByteString.Char8 (unpack)

16+import Data.Scientific (fromFloatDigits)

17+import Data.Fixed (Fixed(MkFixed), Micro, Pico)

18+import Data.String (IsString(fromString))

19+import Data.Time

20+import Squeal.PostgreSQL hiding (check, defaultMain, Group)

21+import Hedgehog hiding (Range)

22+import qualified Hedgehog.Gen as Gen

23+import qualified Hedgehog.Main as Main

24+import qualified Hedgehog.Range as Range

25+

26+main :: IO ()

27+main = Main.defaultMain [checkSequential roundtrips]

28+

29+roundtrips :: Group

30+roundtrips = Group "roundtrips"

31+ [ roundtrip int2 genInt16

32+ , roundtrip int4 genInt32

33+ , roundtrip int8 genInt64

34+ , roundtrip bool Gen.bool

35+ , roundtrip numeric genScientific

36+ , roundtrip float4 genFloat

37+ , roundtrip float8 genDouble

38+ , roundtripOn normalizeTimeOfDay time genTimeOfDay

39+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone

40+ , roundtripOn normalizeLocalTime timestamp genLocalTime

41+ , roundtrip timestamptz genUTCTime

42+ , roundtrip date genDay

43+ , roundtrip interval genDiffTime

44+ , roundtripOn normalizeIntRange int4range (genRange genInt32)

45+ , roundtripOn normalizeIntRange int8range (genRange genInt64)

46+ , roundtrip numrange (genRange genScientific)

47+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)

48+ , roundtrip tstzrange (genRange genUTCTime)

49+ , roundtripOn normalizeIntRange daterange (genRange genDay)

50+ ]

51+ where

52+ genInt16 = Gen.int16 Range.exponentialBounded

53+ genInt32 = Gen.int32 Range.exponentialBounded

54+ genInt64 = Gen.int64 Range.exponentialBounded

55+ genScientific = fromFloatDigits <$> genFloat

56+ genPosFloat = Gen.float

57+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)

58+ genFloat = Gen.prune $ Gen.choice

59+ [ genPosFloat

60+ , negate <$> genPosFloat

61+ , Gen.element [0,1/0] ]

62+ genPosDouble = Gen.double

63+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)

64+ genDouble = Gen.prune $ Gen.choice

65+ [ genPosDouble

66+ , negate <$> genPosDouble

67+ , Gen.element [0,1/0] ]

68+ genRange gen = do

69+ lb <- gen

70+ ub <- Gen.filter (lb <) gen

71+ Gen.element

72+ [ Empty, singleton lb, whole

73+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub

74+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]

75+ genDay = do

76+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)

77+ m <- Gen.int (Range.constant 1 12)

78+ d <- Gen.int (Range.constant 1 28)

79+ return $ fromGregorian y m d

80+ genDiffTime = secondsToDiffTime . toInteger <$>

81+ Gen.int (Range.constant 0 86401)

82+ genUTCTime = UTCTime <$> genDay <*> genDiffTime

83+ genTimeOfDay = do

84+ h <- Gen.int (Range.constant 0 23)

85+ m <- Gen.int (Range.constant 0 59)

86+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)

87+ return $ TimeOfDay h m s

88+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay

89+ -- genTimeZone = Gen.element $ map (read @TimeZone)

90+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"

91+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]

92+ -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone

93+

94+roundtrip

95+ :: (ToParam x ty, FromValue ty x, Show x, Eq x)

96+ => TypeExpression schemas ('NotNull ty)

97+ -> Gen x

98+ -> (PropertyName, Property)

99+roundtrip = roundtripOn id

100+

101+roundtripOn

102+ :: (ToParam x ty, FromValue ty x, Show x, Eq x)

103+ => (x -> x)

104+ -> TypeExpression schemas ('NotNull ty)

105+ -> Gen x

106+ -> (PropertyName, Property)

107+roundtripOn norm ty gen = propertyWithName $ do

108+ x <- forAll gen

109+ Just (Only y) <- lift . withConnection connectionString $

110+ firstRow =<< runQueryParams

111+ (values_ (parameter @1 ty `as` #fromOnly)) (Only x)

112+ norm x === y

113+ where

114+ propertyWithName prop =

115+ (fromString (unpack (renderSQL ty)), property prop)

116+

117+maxPosFloat :: RealFloat a => a

118+maxPosFloat = x

119+ where

120+ n = floatDigits x

121+ b = floatRadix x

122+ (_, u) = floatRange x

123+ x = encodeFloat (b^n - 1) (u - n)

124+

125+minPosFloat :: RealFloat a => a

126+minPosFloat = x

127+ where

128+ n = floatDigits x

129+ b = floatRadix x

130+ (l, _) = floatRange x

131+ x = encodeFloat (b^n - 1) (l - n - 1)

132+

133+connectionString :: ByteString

134+connectionString = "host=localhost port=5432 dbname=exampledb"

135+

136+normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int

137+normalizeIntRange = \case

138+ Empty -> Empty

139+ NonEmpty l u ->

140+ let

141+ l' = normalizeL l

142+ u' = normalizeU u

143+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'

144+ where

145+ normalizeL = \case

146+ Open l -> Closed (succ l)

147+ normalized -> normalized

148+ normalizeU = \case

149+ Closed u -> Open (succ u)

150+ normalized -> normalized

151+ emptyNormalized (Closed l) (Open u) = l >= u

152+ emptyNormalized _ _ = False

153+

154+normalizeTimeOfDay :: TimeOfDay -> TimeOfDay

155+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m

156+ . fromRational @Pico

157+ . toRational @Micro

158+ . fromRational @Micro

159+ . toRational @Pico

160+ $ s

161+

162+normalizeLocalTime :: LocalTime -> LocalTime

163+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)

164+

165+-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)

166+-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)

squeal-postgresql/test/Spec.hsnew file+125

@@ -0,0 +1,125 @@

1+{-# LANGUAGE

2+ DataKinds

3+ , DeriveAnyClass

4+ , DeriveGeneric

5+ , DerivingStrategies

6+ , DuplicateRecordFields

7+ , FlexibleContexts

8+ , OverloadedLabels

9+ , OverloadedLists

10+ , OverloadedStrings

11+ , TypeApplications

12+ , TypeFamilies

13+ , TypeInType

14+ , TypeOperators

15+#-}

16+

17+module Main (main) where

18+

19+import Control.Concurrent.Async (replicateConcurrently)

20+import Data.ByteString (ByteString)

21+import Data.Int (Int32)

22+import Data.Text (Text)

23+import Test.Hspec

24+

25+import qualified Generics.SOP as SOP

26+import qualified GHC.Generics as GHC

27+

28+import Squeal.PostgreSQL

29+

30+main :: IO ()

31+main = hspec spec

32+

33+type Schemas = Public

34+ '[ "users" ::: 'Table (

35+ '[ "pk_users" ::: 'PrimaryKey '["id"]

36+ , "unique_names" ::: 'Unique '["name"]

37+ ] :=>

38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

39+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]

40+

41+data User = User

42+ { userName :: Text

43+ } deriving stock (Eq, Show, GHC.Generic)

44+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

45+

46+insertUser :: Manipulation_ Schemas User ()

47+insertUser = insertInto_ #users

48+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))

49+

50+setup :: Definition (Public '[]) Schemas

51+setup =

52+ createTable #users

53+ ( serial `as` #id :*

54+ notNullable text `as` #name )

55+ ( primaryKey #id `as` #pk_users :*

56+ unique #name `as` #unique_names )

57+

58+teardown :: Definition Schemas (Public '[])

59+teardown = dropTable #users

60+

61+silence :: MonadPQ schemas pq => pq ()

62+silence = manipulate_ $

63+ UnsafeManipulation "SET client_min_messages TO WARNING;"

64+

65+setupDB :: IO ()

66+setupDB = withConnection connectionString $

67+ silence & pqThen (define setup)

68+

69+dropDB :: IO ()

70+dropDB = withConnection connectionString $

71+ silence & pqThen (define teardown)

72+

73+connectionString :: ByteString

74+connectionString = "host=localhost port=5432 dbname=exampledb"

75+

76+spec :: Spec

77+spec = before_ setupDB . after_ dropDB $ do

78+

79+ describe "Exceptions" $ do

80+

81+ let

82+ testUser = User "TestUser"

83+ newUser = manipulateParams_ insertUser

84+ insertUserTwice = newUser testUser >> newUser testUser

85+ err23505 = PQException $ PQState FatalError (Just "23505")

86+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")

87+

88+ it "should be thrown for constraint violation" $

89+ withConnection connectionString insertUserTwice

90+ `shouldThrow` (== err23505)

91+

92+ it "should be rethrown for constraint violation in a transaction" $

93+ withConnection connectionString (transactionally_ insertUserTwice)

94+ `shouldThrow` (== err23505)

95+

96+ describe "Pools" $

97+

98+ it "should manage concurrent transactions" $ do

99+ pool <- createConnectionPool

100+ "host=localhost port=5432 dbname=exampledb" 1 0.5 10

101+ let

102+ query :: Query_ (Public '[]) () (Only Char)

103+ query = values_ (literal 'a' `as` #fromOnly)

104+ session = usingConnectionPool pool . transactionally_ $ do

105+ result <- runQuery query

106+ Just (Only chr) <- firstRow result

107+ return chr

108+ chrs <- replicateConcurrently 10 session

109+ chrs `shouldSatisfy` all (== 'a')

110+

111+ describe "Ranges" $

112+

113+ it "should correctly decode ranges" $ do

114+

115+ rangesOut <- withConnection connectionString $ do

116+ let

117+ query :: Query_ (Public '[]) () (Only (Range Int32))

118+ query = values

119+ ( range int4range (atLeast 3) `as` #fromOnly )

120+ [ range int4range (3 <=..< 5) `as` #fromOnly

121+ , range int4range Empty `as` #fromOnly

122+ , range int4range whole `as` #fromOnly ]

123+ getRows =<< runQuery query

124+ (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`

125+ [ atLeast 3, 3 <=..< 5, Empty, whole ]

squeal-postgresql/test/Specs/ExceptionHandling.hsdeleted−140

@@ -1,140 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DuplicateRecordFields #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE OverloadedLabels #-}

6−{-# LANGUAGE OverloadedLists #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeInType #-}

11−{-# LANGUAGE TypeOperators #-}

12−module ExceptionHandling

13− ( specs

14− , User (..)

15− ) where

16−

17−import Control.Concurrent.Async (replicateConcurrently)

18−import Control.Monad (void)

19−import Control.Monad.IO.Class (MonadIO (..))

20−import Data.Int (Int16)

21−import Data.Text (Text)

22−import Data.Vector (Vector)

23−import Test.Hspec

24−

25−import qualified Data.ByteString.Char8 as Char8

26−import qualified Generics.SOP as SOP

27−import qualified GHC.Generics as GHC

28−

29−import Squeal.PostgreSQL

30−

31−type Schema =

32− '[ "users" ::: 'Table (

33− '[ "pk_users" ::: 'PrimaryKey '["id"]

34− , "unique_names" ::: 'Unique '["name"]

35− ] :=>

36− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

37− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

38− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))

39− ])

40− , "emails" ::: 'Table (

41− '[ "pk_emails" ::: 'PrimaryKey '["id"]

42− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

43− ] :=>

44− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

45− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

46− , "email" ::: 'NoDef :=> 'Null 'PGtext

47− ])

48− ]

49−

50−type Schemas = Public Schema

51−

52−data User =

53− User { userName :: Text

54− , userEmail :: Maybe Text

55− , userVec :: VarArray (Vector (Maybe Int16)) }

56− deriving (Show, GHC.Generic)

57−instance SOP.Generic User

58−instance SOP.HasDatatypeInfo User

59−

60−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]

61− '[ "fromOnly" ::: 'NotNull 'PGint4 ]

62−insertUser = insertInto #users

63− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))

64− OnConflictDoRaise (Returning (#id `as` #fromOnly))

65−

66−setup :: Definition (Public '[]) Schemas

67−setup =

68− createTable #users

69− ( serial `as` #id :*

70− (text & notNullable) `as` #name :*

71− (vararray int2 & notNullable) `as` #vec )

72− ( primaryKey #id `as` #pk_users

73− :* unique #name `as` #unique_names )

74− >>>

75− createTable #emails

76− ( serial `as` #id :*

77− (int & notNullable) `as` #user_id :*

78− (text & nullable) `as` #email )

79− ( primaryKey #id `as` #pk_emails :*

80− foreignKey #user_id #users #id

81− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

82−

83−teardown :: Definition Schemas (Public '[])

84−teardown = dropTable #emails >>> dropTable #users

85−

86−migration :: Migration Definition (Public '[]) Schemas

87−migration = Migration { name = "test"

88− , up = setup

89− , down = teardown }

90−

91−setupDB :: IO ()

92−setupDB = withConnection connectionString $

93− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")

94− & pqThen (migrateUp (single migration))

95−

96−dropDB :: IO ()

97−dropDB = withConnection connectionString $

98− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")

99− & pqThen (migrateDown (single migration))

100−

101−connectionString :: Char8.ByteString

102−connectionString = "host=localhost port=5432 dbname=exampledb"

103−

104−testUser :: User

105−testUser = User "TestUser" Nothing (VarArray [])

106−

107−newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()

108−newUser u = void $ manipulateParams insertUser (userName u, userVec u)

109−

110−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()

111−insertUserTwice = newUser testUser >> newUser testUser

112−

113−specs :: SpecWith ()

114−specs = before_ setupDB $ after_ dropDB $

115− describe "Exceptions" $ do

116−

117− let

118− dupKeyErr = PQException $ PQState FatalError (Just "23505")

119− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")

120−

121− it "should be thrown for unique constraint violation in a manipulation" $

122− withConnection connectionString insertUserTwice

123− `shouldThrow` (== dupKeyErr)

124−

125− it "should be rethrown for unique constraint violation in a manipulation by a transaction" $

126− withConnection connectionString (transactionally_ insertUserTwice)

127− `shouldThrow` (== dupKeyErr)

128−

129− it "should handle concurrent transactions using pooled connections" $ do

130− pool <- createConnectionPool

131− "host=localhost port=5432 dbname=exampledb" 1 0.5 10

132− let

133− query :: Query_ (Public '[]) () (Only Char)

134− query = values_ (literal 'a' `as` #fromOnly)

135− session = usingConnectionPool pool . transactionally_ $ do

136− result <- runQuery query

137− Just (Only chr) <- firstRow result

138− return chr

139− chrs <- replicateConcurrently 10 session

140− chrs `shouldSatisfy` (all (== 'a'))

squeal-postgresql/test/Specs/Specs.hsdeleted−7

@@ -1,7 +0,0 @@

1−module Main where

2−

3−import Test.Hspec

4−import qualified ExceptionHandling

5−

6−main :: IO ()

7−main = hspec ExceptionHandling.specs

stack.yaml+1−1

@@ -1,4 +1,4 @@

1−resolver: lts-13.25

1+resolver: nightly-2019-07-14

2packages:

3- squeal-postgresql

4