@@ -1,5 +1,7 @@
11{-# LANGUAGE
22 DataKinds
3+ , GADTs
4+ , LambdaCase
35 , OverloadedLabels
46 , OverloadedStrings
57 , TypeApplications
@@ -11,6 +13,8 @@ module Property (propertyTests) where
1113import Control.Monad.Trans
1214import Data.ByteString (ByteString)
1315import Data.Scientific (fromFloatDigits)
16+import Data.Fixed (Fixed(MkFixed), Micro, Pico)
17+import Data.Time
1418import Squeal.PostgreSQL hiding (check, defaultMain)
1519import Hedgehog hiding (Range)
1620import qualified Hedgehog.Gen as Gen
@@ -19,28 +23,111 @@ import qualified Hedgehog.Range as Range
1923
2024propertyTests :: IO ()
2125propertyTests = Main.defaultMain
22− [ roundtrip int2 (Gen.int16 Range.exponentialBounded)
23− , roundtrip int4 (Gen.int32 Range.exponentialBounded)
24− , roundtrip int8 (Gen.int64 Range.exponentialBounded)
25− , roundtrip bool Gen.bool
26− , roundtrip numeric (scientific (Range.exponentialFloatFrom 0 (-1E9) 1E9))
27− , roundtrip float4 (Gen.float (Range.exponentialFloatFrom 0 (-1E9) 1E9))
28− , roundtrip float8 (Gen.double (Range.exponentialFloatFrom 0 (-1E308) 1E308))
26+ [ roundtrip int2 genInt16 id
27+ , roundtrip int4 genInt32 id
28+ , roundtrip int8 genInt64 id
29+ , roundtrip bool Gen.bool id
30+ , roundtrip numeric genScientific id
31+ , roundtrip float4 genFloat id
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
2945 ]
3046 where
31− scientific = fmap fromFloatDigits . Gen.float
47+ genInt16 = Gen.int16 Range.exponentialBounded
48+ genInt32 = Gen.int32 Range.exponentialBounded
49+ genInt64 = Gen.int64 Range.exponentialBounded
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
3286
3387connectionString :: ByteString
3488connectionString = "host=localhost port=5432 dbname=exampledb"
3589
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+
36122roundtrip
37123 :: (ToParam x ty, FromValue ty x, Show x, Eq x)
38124 => TypeExpression schemas ('NotNull ty)
39125 -> Gen x
126+ -> (x -> x)
40127 -> IO Bool
41−roundtrip ty gen = check . property $ do
128+roundtrip ty gen norm = check . property $ do
42129 x <- forAll gen
43130 Just (Only y) <- lift . withConnection connectionString $
44131 firstRow =<< runQueryParams
45132 (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
46− x === y
133+ norm x === y