git.iko.soy/squeal
on dev help sign in
time and time range tests
1afd17cEitan Chatav
squeal-postgresql/squeal-postgresql.cabal+1
compare with dev
unifiedsplit
@@ -102,6 +102,7 @@ test-suite squeal-postgresql-test
102 , scientific >= 0.3.5.3
102 , scientific >= 0.3.5.3
103 , squeal-postgresql
103 , squeal-postgresql
104 , text >= 1.2.2.2
104 , text >= 1.2.2.2
105+ , time >= 1.8.0.2
105 , transformers >= 0.5.2.0
106 , transformers >= 0.5.2.0
106 , vector >= 0.12.0.1
107 , vector >= 0.12.0.1
107
108
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+6−2
@@ -56,9 +56,11 @@ module Squeal.PostgreSQL.Expression.Type
56 , bytea
56 , bytea
57 , timestamp
57 , timestamp
58 , timestampWithTimeZone
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
@@ -219,8 +221,9 @@ bytea = UnsafeTypeExpression "bytea"
219timestamp :: TypeExpression schemas (null 'PGtimestamp)
221timestamp :: TypeExpression schemas (null 'PGtimestamp)
220timestamp = UnsafeTypeExpression "timestamp"
222timestamp = UnsafeTypeExpression "timestamp"
221-- | date and time, including time zone
223-- | date and time, including time zone
222−timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
224+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
223timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
225timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
226+timestamptz = UnsafeTypeExpression "timestamptz"
224-- | calendar date (year, month, day)
227-- | calendar date (year, month, day)
225date :: TypeExpression schemas (null 'PGdate)
228date :: TypeExpression schemas (null 'PGdate)
226date = UnsafeTypeExpression "date"
229date = UnsafeTypeExpression "date"
@@ -228,8 +231,9 @@ date = UnsafeTypeExpression "date"
228time :: TypeExpression schemas (null 'PGtime)
231time :: TypeExpression schemas (null 'PGtime)
229time = UnsafeTypeExpression "time"
232time = UnsafeTypeExpression "time"
230-- | time of day, including time zone
233-- | time of day, including time zone
231−timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
234+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
232timeWithTimeZone = UnsafeTypeExpression "time with time zone"
235timeWithTimeZone = UnsafeTypeExpression "time with time zone"
236+timetz = UnsafeTypeExpression "timetz"
233-- | time span
237-- | time span
234interval :: TypeExpression schemas (null 'PGinterval)
238interval :: TypeExpression schemas (null 'PGinterval)
235interval = UnsafeTypeExpression "interval"
239interval = UnsafeTypeExpression "interval"
squeal-postgresql/test/Property.hs+97−10
@@ -1,5 +1,7 @@
1{-# LANGUAGE
1{-# LANGUAGE
2 DataKinds
2 DataKinds
3+ , GADTs
4+ , LambdaCase
3 , OverloadedLabels
5 , OverloadedLabels
4 , OverloadedStrings
6 , OverloadedStrings
5 , TypeApplications
7 , TypeApplications
@@ -11,6 +13,8 @@ module Property (propertyTests) where
11import Control.Monad.Trans
13import Control.Monad.Trans
12import Data.ByteString (ByteString)
14import Data.ByteString (ByteString)
13import Data.Scientific (fromFloatDigits)
15import Data.Scientific (fromFloatDigits)
16+import Data.Fixed (Fixed(MkFixed), Micro, Pico)
17+import Data.Time
14import Squeal.PostgreSQL hiding (check, defaultMain)
18import Squeal.PostgreSQL hiding (check, defaultMain)
15import Hedgehog hiding (Range)
19import Hedgehog hiding (Range)
16import qualified Hedgehog.Gen as Gen
20import qualified Hedgehog.Gen as Gen
@@ -19,28 +23,111 @@ import qualified Hedgehog.Range as Range
19
23
20propertyTests :: IO ()
24propertyTests :: IO ()
21propertyTests = Main.defaultMain
25propertyTests = Main.defaultMain
22− [ roundtrip int2 (Gen.int16 Range.exponentialBounded)
26+ [ roundtrip int2 genInt16 id
23− , roundtrip int4 (Gen.int32 Range.exponentialBounded)
27+ , roundtrip int4 genInt32 id
24− , roundtrip int8 (Gen.int64 Range.exponentialBounded)
28+ , roundtrip int8 genInt64 id
25− , roundtrip bool Gen.bool
29+ , roundtrip bool Gen.bool id
26− , roundtrip numeric (scientific (Range.exponentialFloatFrom 0 (-1E9) 1E9))
30+ , roundtrip numeric genScientific id
27− , roundtrip float4 (Gen.float (Range.exponentialFloatFrom 0 (-1E9) 1E9))
31+ , roundtrip float4 genFloat id
28− , roundtrip float8 (Gen.double (Range.exponentialFloatFrom 0 (-1E308) 1E308))
32+ , roundtrip float8 genDouble id
33+ , roundtrip time genTimeOfDay normalizeTimeOfDay
34+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
35+ , roundtrip timestamp genLocalTime normalizeLocalTime
36+ , roundtrip timestamptz genUTCTime id
37+ , roundtrip date genDay id
38+ , roundtrip interval genDiffTime id
39+ , roundtrip int4range (genRange genInt32) normalizeIntRange
40+ , roundtrip int8range (genRange genInt64) normalizeIntRange
41+ , roundtrip numrange (genRange genScientific) id
42+ , roundtrip tsrange (genRange genLocalTime) (fmap normalizeLocalTime)
43+ , roundtrip tstzrange (genRange genUTCTime) id
44+ , roundtrip daterange (genRange genDay) normalizeIntRange
29 ]
45 ]
30 where
46 where
47+ genInt16 = Gen.int16 Range.exponentialBounded
48+ genInt32 = Gen.int32 Range.exponentialBounded
49+ genInt64 = Gen.int64 Range.exponentialBounded
31− scientific = fmap fromFloatDigits . Gen.float
50+ genScientific = fromFloatDigits <$>
51+ Gen.float (Range.exponentialFloatFrom 0 (-1E9) 1E9)
52+ genFloat = Gen.float (Range.exponentialFloatFrom 0 (-1E9) 1E9)
53+ genDouble = Gen.double (Range.exponentialFloatFrom 0 (-1E308) 1E308)
54+ genRange gen = do
55+ lb <- gen
56+ ub <- Gen.filter (lb <=) gen
57+ Gen.element
58+ [ Empty
59+ , NonEmpty (Closed lb) (Closed ub)
60+ , NonEmpty (Closed lb) (Open ub)
61+ , NonEmpty (Closed lb) Infinite
62+ , NonEmpty (Open lb) (Closed ub)
63+ , NonEmpty (Open lb) (Open ub)
64+ , NonEmpty (Open lb) Infinite
65+ , NonEmpty Infinite (Closed ub)
66+ , NonEmpty Infinite (Open ub)
67+ , NonEmpty Infinite Infinite ]
68+ genDay = do
69+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)
70+ m <- Gen.int (Range.constant 1 12)
71+ d <- Gen.int (Range.constant 1 28)
72+ return $ fromGregorian y m d
73+ genDiffTime = secondsToDiffTime . toInteger <$>
74+ Gen.int (Range.constant 0 86401)
75+ genUTCTime = UTCTime <$> genDay <*> genDiffTime
76+ genTimeOfDay = do
77+ h <- Gen.int (Range.constant 0 23)
78+ m <- Gen.int (Range.constant 0 59)
79+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
80+ return $ TimeOfDay h m s
81+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
82+ genTimeZone = Gen.element $ map (read @TimeZone)
83+ [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
84+ , "CDT", "MST", "MDT", "PST", "PDT" ]
85+ genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
32
86
33connectionString :: ByteString
87connectionString :: ByteString
34connectionString = "host=localhost port=5432 dbname=exampledb"
88connectionString = "host=localhost port=5432 dbname=exampledb"
35
89
90+normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
91+normalizeIntRange = \case
92+ Empty -> Empty
93+ NonEmpty l u ->
94+ let
95+ l' = normalizeL l
96+ u' = normalizeU u
97+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'
98+ where
99+ normalizeL = \case
100+ Open l -> Closed (succ l)
101+ normalized -> normalized
102+ normalizeU = \case
103+ Closed u -> Open (succ u)
104+ normalized -> normalized
105+ emptyNormalized (Closed l) (Open u) = l >= u
106+ emptyNormalized _ _ = False
107+
108+normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
109+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
110+ . fromRational @Pico
111+ . toRational @Micro
112+ . fromRational @Micro
113+ . toRational @Pico
114+ $ s
115+
116+normalizeLocalTime :: LocalTime -> LocalTime
117+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
118+
119+normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
120+normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
121+
36roundtrip
122roundtrip
37 :: (ToParam x ty, FromValue ty x, Show x, Eq x)
123 :: (ToParam x ty, FromValue ty x, Show x, Eq x)
38 => TypeExpression schemas ('NotNull ty)
124 => TypeExpression schemas ('NotNull ty)
39 -> Gen x
125 -> Gen x
126+ -> (x -> x)
40 -> IO Bool
127 -> IO Bool
41−roundtrip ty gen = check . property $ do
128+roundtrip ty gen norm = check . property $ do
42 x <- forAll gen
129 x <- forAll gen
43 Just (Only y) <- lift . withConnection connectionString $
130 Just (Only y) <- lift . withConnection connectionString $
44 firstRow =<< runQueryParams
131 firstRow =<< runQueryParams
45 (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
132 (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
46− x === y
133+ norm x === y