{-# LANGUAGE
DataKinds
, DeriveAnyClass
, DeriveGeneric
, DerivingStrategies
, DerivingVia
, FlexibleContexts
, FlexibleInstances
, GADTs
, LambdaCase
, MultiParamTypeClasses
, OverloadedLabels
, OverloadedStrings
, ScopedTypeVariables
, StandaloneDeriving
, TypeApplications
, TypeOperators
, UndecidableInstances
#-}
module Main (main) where
import Control.Monad.Trans
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (unpack)
import Data.Function (on)
import Data.Functor.Contravariant (contramap)
import Data.Int (Int16)
import Data.Scientific (fromFloatDigits)
import Data.Fixed (Fixed(MkFixed), Micro, Pico)
import Data.String (IsString(fromString))
import Data.Time
import Hedgehog hiding (Range)
import Main.Utf8
import Squeal.PostgreSQL hiding (check)
import qualified Generics.SOP as SOP
import qualified GHC.Generics as GHC
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Main as Main
import qualified Hedgehog.Range as Range
import Data.List (sort)
main :: IO ()
main = withUtf8 $ do
withConnection connectionString $ define createDB
Main.defaultMain [checkSequential roundtrips]
withConnection connectionString $ define dropDB
roundtrips :: Group
roundtrips = Group "roundtrips"
[ roundtrip int2 genInt16
, roundtrip int4 genInt32
, roundtrip int8 genInt64
, roundtrip bool Gen.bool
, roundtrip numeric genScientific
, roundtrip float4 genFloat
, roundtrip float8 genDouble
, roundtripOn normalizeAscii text genStringAscii
, roundtripOn normalizeUtf8 text genStringUnicode
-- , roundtripOn normalizeUtf8 text genStringAll
, roundtripOn normalizeTimeOfDay time genTimeOfDay
-- , roundtrip timetz genTimeWithZone
, roundtripOn normalizeLocalTime timestamp genLocalTime
, roundtrip timestamptz genUTCTime
, roundtrip date genDay
, roundtrip interval genDiffTime
, roundtripOn normalizeIntRange int4range (genRange genInt32)
, roundtripOn normalizeIntRange int8range (genRange genInt64)
, roundtrip numrange (genRange genScientific)
, roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
, roundtrip tstzrange (genRange genUTCTime)
, roundtripOn normalizeIntRange daterange (genRange genDay)
, roundtrip (typedef #schwarma) genSchwarma
, roundtrip (vararray (typedef #schwarma)) genSchwarmaArray
, roundtrip (typerow #tab) genRow
, roundtrip (vararray (typetable #tab)) genRowArray
, ("table insert", roundtripTable)
]
where
genInt16 = Gen.int16 Range.exponentialBounded
genInt32 = Gen.int32 Range.exponentialBounded
genInt64 = Gen.int64 Range.exponentialBounded
genScientific = fromFloatDigits <$> genFloat
genPosFloat = Gen.float
(Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
genFloat = Gen.prune $ Gen.choice
[ genPosFloat
, negate <$> genPosFloat
, Gen.element [0,1/0,-1/0]
]
genPosDouble = Gen.double
(Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
genDouble = Gen.prune $ Gen.choice
[ genPosDouble
, negate <$> genPosDouble
, Gen.element [0,1/0,-1/0]
]
genStringAscii = Gen.string (Range.linear 0 100) Gen.ascii
-- genStringLatin1 = Gen.string (Range.linear 0 100) Gen.latin1
genStringUnicode = Gen.string (Range.linear 0 100) Gen.unicode
-- genStringAll = Gen.string (Range.linear 0 100) Gen.unicodeAll
genRange gen = do
lb <- gen
ub <- Gen.filter (lb <) gen
Gen.element
[ Empty, singleton lb, whole
, lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
, atLeast lb, moreThan lb, atMost ub, lessThan ub ]
genDay = do
y <- toInteger <$> Gen.int (Range.constant 2000 2019)
m <- Gen.int (Range.constant 1 12)
d <- Gen.int (Range.constant 1 28)
return $ fromGregorian y m d
genDiffTime = do
secs <- secondsToDiffTime . toInteger <$>
Gen.int (Range.constant 0 86401)
picos <- picosecondsToDiffTime . (* 1000000) . toInteger <$>
Gen.int (Range.constant 0 (1000000 - 1))
return $ secs + picos
genUTCTime = UTCTime <$> genDay <*> genDiffTime
genTimeOfDay = do
h <- Gen.int (Range.constant 0 23)
m <- Gen.int (Range.constant 0 59)
s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
return $ TimeOfDay h m s
genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
-- genTimeZone = Gen.element $ map (read @TimeZone)
-- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
-- , "CDT", "MST", "MDT", "PST", "PDT" ]
genSchwarma = Gen.enumBounded @_ @Schwarma
genSchwarmaArray = VarArray <$> Gen.list (Range.constant 1 10) genSchwarma
genRow = HaskRow
<$> genInt16
<*> Gen.enumBounded
<*> Gen.bool
genRowArray = VarArray <$> Gen.list (Range.constant 1 10) genRow
roundtrip
:: forall x
. ( ToPG DB x, FromPG x, Inline x
, OidOf DB (PG x), PGTyped DB (PG x)
, Show x, Eq x, NullPG x ~ 'NotNull (PG x) )
=> TypeExpression DB ('NotNull (PG x))
-> Gen x
-> (PropertyName, Property)
roundtrip = roundtripOn id
roundtripOn
:: forall x
. ( ToPG DB x, FromPG x, Inline x
, OidOf DB (PG x), PGTyped DB (PG x)
, Show x, Eq x, NullPG x ~ 'NotNull (PG x) )
=> (x -> x)
-> TypeExpression DB ('NotNull (PG x))
-> Gen x
-> (PropertyName, Property)
roundtripOn norm ty gen = propertyWithName $ do
x <- forAll gen
Just (Only y) <- lift . withConnection connectionString $
firstRow =<< runQueryParams
(values_ (parameter @1 ty `as` #fromOnly)) (Only x)
Just (Only z) <- lift . withConnection connectionString $
firstRow =<< runQuery
(values_ (inline @x @'NotNull x `as` #fromOnly))
y === z
norm x === y
where
propertyWithName prop =
(fromString (unpack (renderSQL ty)), property prop)
maxPosFloat :: RealFloat a => a
maxPosFloat = x
where
n = floatDigits x
b = floatRadix x
(_, u) = floatRange x
x = encodeFloat (b^n - 1) (u - n)
minPosFloat :: RealFloat a => a
minPosFloat = x
where
n = floatDigits x
b = floatRadix x
(l, _) = floatRange x
x = encodeFloat (b^n - 1) (l - n - 1)
connectionString :: ByteString
connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
normalizeIntRange = \case
Empty -> Empty
NonEmpty l u ->
let
l' = normalizeL l
u' = normalizeU u
in if emptyNormalized l' u' then Empty else NonEmpty l' u'
where
normalizeL = \case
Open l -> Closed (succ l)
normalized -> normalized
normalizeU = \case
Closed u -> Open (succ u)
normalized -> normalized
emptyNormalized (Closed l) (Open u) = l >= u
emptyNormalized _ _ = False
normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
. fromRational @Pico
. toRational @Micro
. fromRational @Micro
. toRational @Pico
$ s
normalizeLocalTime :: LocalTime -> LocalTime
normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
normalizeAscii :: String -> String
normalizeAscii = (stripped =<<)
where
stripped = \case
'\NUL' -> ""
ch -> [ch]
normalizeUtf8 :: String -> String
normalizeUtf8 = (stripped =<<)
where
stripped = \case
'\NUL' -> ""
ch -> [ch]
data Schwarma = Chicken | Lamb | Beef
deriving stock (Eq, Ord, Show, Bounded, Enum, GHC.Generic)
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
deriving (IsPG, FromPG, ToPG db, Inline) via Enumerated Schwarma
data HaskRow = HaskRow {foo :: Int16, bar :: Schwarma, baz :: Bool}
deriving stock (Eq, Ord, Show, GHC.Generic)
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
deriving (IsPG, FromPG, Inline) via Composite HaskRow
deriving via Composite HaskRow
instance db ~ DB => ToPG db HaskRow
type Schema = '[
"schwarma" ::: 'Typedef (PG Schwarma),
"tab" ::: 'Table ('[] :=> PGRow)]
type DB = Public Schema
type DB0 = Public '[]
createDB :: Definition DB0 DB
createDB =
createTypeEnumFrom @Schwarma #schwarma >>>
createTable #tab
( notNullable int2 `as` #foo :*
notNullable (typedef #schwarma) `as` #bar :*
notNullable bool `as` #baz
) Nil
dropDB :: Definition DB DB0
dropDB = dropTable #tab >>> dropType #schwarma
type PGRow = '[
"foo" ::: 'NoDef :=> 'NotNull 'PGint2,
"bar" ::: 'NoDef :=> 'NotNull (PG Schwarma),
"baz" ::: 'NoDef :=> 'NotNull 'PGbool]
insertTabInline :: [HaskRow] -> Statement DB () ()
insertTabInline = \case
[] -> error "needs at least 1 row"
rw:rows -> manipulation $ insertInto_ #tab (inlineValues rw rows)
insertTabParams :: Statement DB HaskRow ()
insertTabParams = manipulation . insertInto_ #tab . Values_ $
Set (param @1) `as` #foo :*
Set (param @2) `as` #bar :*
Set (param @3) `as` #baz
insertTabUnnest :: Statement DB [HaskRow] ()
insertTabUnnest = Manipulation enc dec sql
where
enc = contramap VarArray aParam
dec = return ()
sql = insertInto_ #tab unnested
unnested = Select fields (from (unnest (param @1)))
fields =
Set (#unnest & field #tab #foo) `as` #foo :*
Set (#unnest & field #tab #bar) `as` #bar :*
Set (#unnest & field #tab #baz) `as` #baz
selectTab :: Statement DB () HaskRow
selectTab = query $ select Star (from (table #tab))
roundtripTable :: Property
roundtripTable = property $ do
let
genInt16 = Gen.int16 Range.exponentialBounded
genRow = HaskRow
<$> genInt16
<*> Gen.enumBounded
<*> Gen.bool
genRows = Gen.list (Range.constant 1 100) genRow
rows1 <- forAll genRows
rows2 <- forAll genRows
rows3 <- forAll genRows
tabRows <- lift . withConnection connectionString $ ephemerally_ $ do
execute_ (insertTabInline rows1)
executePrepared_ insertTabParams rows2
executeParams_ insertTabUnnest rows3
getRows =<< execute selectTab
((===) `on` sort) tabRows (rows1 ++ rows2 ++ rows3)