Codec.hs

module Sq.Test.Codec (tree) where

import Control.Exception.Safe qualified as Ex
import Control.Monad.IO.Class
import Data.Aeson qualified as Ae
import Data.Binary qualified as Bin
import Data.Bits
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Data.Fixed
import Data.Functor.Contravariant
import Data.Int
import Data.Maybe
import Data.Scientific qualified as Sci
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Time qualified as Time
import Data.Time.Clock.POSIX qualified as Time
import Data.Time.Format.ISO8601 qualified as Time
import Data.Typeable
import Data.UUID.Types qualified as UUID
import Data.Word
import GHC.Generics qualified as G
import Hedgehog qualified as H
import Hedgehog.Gen qualified as H
import Hedgehog.Range qualified as HR
import Numeric.Natural
import Sq qualified
import Test.Tasty (testGroup)
import Test.Tasty.Hedgehog (testProperty)
import Test.Tasty.Runners (TestTree)

--------------------------------------------------------------------------------

tree :: IO (Sq.Pool Sq.Write) -> TestTree
tree iop =
   testGroup
      "decode . encode"
      [ t @Bool $ H.bool
      , t @UUID.UUID uuid4
      , t @Int $ H.integral HR.constantBounded
      , t @Int8 $ H.integral HR.constantBounded
      , t @Int16 $ H.integral HR.constantBounded
      , t @Int32 $ H.integral HR.constantBounded
      , t @Int64 $ H.integral HR.constantBounded
      , t @Word $ H.integral HR.constantBounded
      , t @Word8 $ H.integral HR.constantBounded
      , t @Word16 $ H.integral HR.constantBounded
      , t @Word32 $ H.integral HR.constantBounded
      , t @Word64 $ H.integral HR.constantBounded
      , t @Word64 $ H.integral HR.constantBounded
      , t @Natural $ H.integral $ HR.constant 0 maxNatural
      , t @Integer $ H.integral $ HR.constantFrom 0 minInteger maxInteger
      , t @Char H.unicode
      , t @String $ H.string (HR.constant 0 50) H.unicode
      , t @T.Text $ H.text (HR.constant 0 50) H.unicode
      , t @TL.Text $ fmap TL.fromStrict $ H.text (HR.constant 0 50) H.unicode
      , t2 @B.ByteString $ H.bytes (HR.constant 0 50)
      , t2 @BL.ByteString $ fmap BL.fromStrict $ H.bytes (HR.constant 0 50)
      , t2 @Time.UTCTime $ genUTCTime (HR.constantFrom epochUTCTime minUTCTime maxUTCTime)
      , t @Double $ H.double (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))
      , t @Float $ H.float (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))
      , t @Sci.Scientific $ genScientific (HR.constantFrom 0 (-10) 10) HR.constantBounded
      , t @(Fixed E0) $ genFixed (HR.constantFrom 0 minInteger maxInteger)
      , t @(Fixed E2) $ genFixed (HR.constantFrom 0 minInteger maxInteger)
      , t @(Fixed E9) $ genFixed (HR.constantFrom 0 minInteger maxInteger)
      , -- TODO FAIL: , testProperty "Char" $ t @Char (pure '\55296')
        tGeneric
      ]
  where
   t
      :: forall a
       . ( Typeable a
         , Eq a
         , Show a
         , Sq.EncodeDefault a
         , Sq.DecodeDefault a
         , Bin.Binary a
         , Ae.ToJSON a
         , Ae.FromJSON a
         )
      => H.Gen a
      -> TestTree
   t ga =
      testGroup
         (tyConName (typeRepTyCon (typeRep ga)))
         [ testGroup "raw" [t2 ga]
         , testGroup "binary" [t2 (WrapBinary <$> ga)]
         , testGroup "aeson" [t2 (WrapAeson <$> ga)]
         ]

   t2
      :: forall a
       . (Typeable a, Eq a, Show a, Sq.EncodeDefault a, Sq.DecodeDefault a)
      => H.Gen a
      -> TestTree
   t2 ga =
      testGroup
         (tyConName (typeRepTyCon (typeRep ga)))
         [ testProperty "pure" $ H.property do
            a0 <- H.forAll ga
            let Sq.Encode g = Sq.encodeDefault
            case g a0 of
               Left e0 -> Ex.throwM e0
               Right raw -> do
                  let Sq.Decode f = Sq.decodeDefault
                  case f raw of
                     Left e -> Ex.throwM e
                     Right a1 -> a0 H.=== a1
         , testProperty "db" $ H.property do
            p <- liftIO iop
            a0 <- H.forAll ga
            a1 <- Sq.read p $ Sq.one idStatement a0
            a0 H.=== a1
         ]
   tGeneric :: TestTree
   tGeneric =
      testGroup
         "Generic InputDefault/OutputDefault"
         [ testProperty "Foo" $ H.property do
            p <- liftIO iop
            a0 <- H.forAll genFoo
            a1 <- Sq.read p do
               Sq.one
                  ( Sq.readStatement
                     Sq.inputDefault
                     Sq.outputDefault
                     "SELECT $x AS x, $y AS y"
                  )
                  a0
            Foo0{x = a0.x, y = a0.y} H.=== a1
         ]

newtype WrapBinary a = WrapBinary a
   deriving newtype (Eq, Show)

instance (Bin.Binary a) => Sq.EncodeDefault (WrapBinary a) where
   encodeDefault = Sq.encodeBinary >$$< \(WrapBinary a) -> a

instance (Bin.Binary a) => Sq.DecodeDefault (WrapBinary a) where
   decodeDefault = WrapBinary <$> Sq.decodeBinary

newtype WrapAeson a = WrapAeson a
   deriving newtype (Eq, Show)

instance (Ae.ToJSON a) => Sq.EncodeDefault (WrapAeson a) where
   encodeDefault = Sq.encodeAeson >$$< \(WrapAeson a) -> a

instance (Ae.FromJSON a) => Sq.DecodeDefault (WrapAeson a) where
   decodeDefault = WrapAeson <$> Sq.decodeAeson

idStatement
   :: (Sq.EncodeDefault x, Sq.DecodeDefault x)
   => Sq.Statement Sq.Read x x
idStatement =
   Sq.readStatement
      (Sq.input "a" (Sq.input "b" "c"))
      (Sq.output "x" (Sq.output "y" "z"))
      "SELECT $a__b__c AS x__y__z"

uuid4 :: (H.MonadGen m) => m UUID.UUID
uuid4 =
   UUID.fromWords64
      <$> H.integral HR.constantBounded
      <*> H.integral HR.constantBounded

maxNatural :: Natural
maxNatural = 2 ^ (256 :: Int) - 1

maxInteger :: Integer
maxInteger = 2 ^ (255 :: Int) - 1

minInteger :: Integer
minInteger = complement maxInteger

minUTCTime :: Time.UTCTime
minUTCTime = fromJust $ Time.iso8601ParseM "-9999-01-01T00:00:00Z"

maxUTCTime :: Time.UTCTime
maxUTCTime = fromJust $ Time.iso8601ParseM "9999-12-31T24:00:00Z"

epochUTCTime :: Time.UTCTime
epochUTCTime = posixPicoSecondsToUTCTime 0

genUTCTime :: (H.MonadGen m) => H.Range Time.UTCTime -> m Time.UTCTime
genUTCTime =
   fmap posixPicoSecondsToUTCTime
      . H.integral
      . fmap utcTimeToPOSIXPicoSeconds

utcTimeToPOSIXPicoSeconds :: Time.UTCTime -> Integer
utcTimeToPOSIXPicoSeconds t = i
  where
   MkFixed i = Time.nominalDiffTimeToSeconds $ Time.utcTimeToPOSIXSeconds t

posixPicoSecondsToUTCTime :: Integer -> Time.UTCTime
posixPicoSecondsToUTCTime =
   Time.posixSecondsToUTCTime . Time.secondsToNominalDiffTime . MkFixed

genScientific
   :: (H.MonadGen m)
   => H.Range Integer
   -> H.Range Int
   -> m Sci.Scientific
genScientific rc re = Sci.scientific <$> H.integral rc <*> H.integral re

genFixed :: (H.MonadGen m) => H.Range Integer -> m (Fixed e)
genFixed ri = MkFixed <$> H.integral ri

-- genRational :: (H.MonadGen m) => m Rational
-- genRational = do
--    n <- genInteger
--    d <- H.integral $ H.linear 1 (10 ^ (10 :: Int))
--    pure (n % d)

data Foo
   = Foo0 {x :: Int, y :: String}
   | Foo1 {x :: Int, y :: String}
   deriving (Eq, Show, G.Generic, Sq.InputDefault, Sq.OutputDefault)

genFoo :: (H.MonadGen m) => m Foo
genFoo = do
   x <- H.integral HR.constantBounded
   y <- H.string (HR.constant 0 50) H.unicode
   H.element [Foo0 x y, Foo1 x y]