Roundtrip.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP                 #-}
-- |
module TST.Roundtrip (tests) where

import Data.Int
import Data.Word
import Data.Typeable
import Data.Set        (Set)
import Data.Map.Strict (Map)
import Data.Text       qualified as T
import Data.Text.Lazy  qualified as TL
import Data.Complex (Complex)
import Foreign.C.Types

import Test.Tasty
import Test.Tasty.QuickCheck
import Test.QuickCheck.Instances.Vector ()
import Test.QuickCheck.Instances.ByteString ()
import Test.QuickCheck.Instances.Text ()
import Python.Inline
import Python.Inline.QQ

import Data.ByteString             qualified as BS
import Data.ByteString.Lazy        qualified as BL
import Data.ByteString.Short       qualified as SBS
import Data.Vector                 qualified as V
#if MIN_VERSION_vector(0,13,2)
import Data.Vector.Strict          qualified as VV
#endif
import Data.Vector.Storable        qualified as VS
import Data.Vector.Primitive       qualified as VP
import Data.Vector.Unboxed         qualified as VU


tests :: TestTree
tests = testGroup "Roundtrip"
  [ testGroup "Roundtrip"
    [ -- Integral types
      testRoundtrip @Int8
    , testRoundtrip @Int16
    , testRoundtrip @Int32
    , testRoundtrip @Int64
    , testRoundtrip @Int
    , testRoundtrip @Word8
    , testRoundtrip @Word16
    , testRoundtrip @Word32
    , testRoundtrip @Word64
    , testRoundtrip @Word
      -- C wrappers
    , testRoundtrip @CChar
    , testRoundtrip @CSChar
    , testRoundtrip @CUChar
    , testRoundtrip @CShort
    , testRoundtrip @CUShort
    , testRoundtrip @CInt
    , testRoundtrip @CUInt
    , testRoundtrip @CLong
    , testRoundtrip @CULong
    , testRoundtrip @CLLong
    , testRoundtrip @CULLong
      -- Floating point
    , testRoundtrip @Double
    , testRoundtrip @Float
      -- Complex
    , testRoundtrip @(Complex Double)
    , testRoundtrip @(Complex Float)
      -- Other scalars
    , testRoundtrip @Char
    , testRoundtrip @Bool
      -- Containers
    , testRoundtrip @(Int,Char)
    , testRoundtrip @(Int,(Int,Int))
    , testRoundtrip @(Int,Int,Int)
    , testRoundtrip @(Int,Int,Int,Char)
    , testRoundtrip @(Maybe Int)
    , testRoundtrip @(Maybe T.Text)
    , testRoundtrip @[Int]
    , testRoundtrip @[[Int]]
    , testRoundtrip @[Complex Double]
    , testRoundtrip @(Set Int)
    , testRoundtrip @(Map Int Int)
    -- , testRoundtrip @String -- Trips on zero byte as it should
    , testRoundtrip @(V.Vector Int)
    , testRoundtrip @(VS.Vector Int)
    , testRoundtrip @(VP.Vector Int)
    , testRoundtrip @(VU.Vector Int)
#if MIN_VERSION_vector(0,13,2)
--    , testRoundtrip @(VV.Vector Int)
#endif
    , testRoundtrip @BS.ByteString
    , testRoundtrip @BL.ByteString
    , testRoundtrip @SBS.ShortByteString
    , testRoundtrip @T.Text
    , testRoundtrip @TL.Text
    ]
  , testGroup "OutOfRange"
    [ testOutOfRange @Int8   @Int16
    , testOutOfRange @Int16  @Int32
    , testOutOfRange @Int32  @Int64
    , testOutOfRange @Word8  @Word16
    , testOutOfRange @Word16 @Word32
    , testOutOfRange @Word32 @Word64
    ]
  ]

testRoundtrip
  :: forall a. (FromPy a, ToPy a, Eq a, Arbitrary a, Show a, Typeable a) => TestTree
testRoundtrip = testProperty (show (typeOf (undefined :: a))) (propRoundtrip @a)

testOutOfRange
  :: forall a wide. (ToPy wide, FromPy a, Eq a, Eq wide, Integral wide, Integral a
                    , Typeable a, Typeable wide, Arbitrary wide, Show wide
                    )
  => TestTree
testOutOfRange = testProperty
  (show (typeOf (undefined :: a)) ++ " [" ++ show (typeOf (undefined::wide)) ++ "]")
  (propOutOfRange @a @wide)

propRoundtrip :: forall a. (FromPy a, ToPy a, Eq a) => a -> Property
propRoundtrip a = ioProperty $ do
  a' <- runPy $ fromPy' =<< [pye| a_hs |]
  pure $ a == a'


-- Check that values out of range produce out of range
propOutOfRange
  :: forall a wide. (ToPy wide, FromPy a, Eq a, Eq wide, Integral wide, Integral a)
  => wide -> Property
propOutOfRange wide = ioProperty $ do
  a_py <- runPy $ fromPy @a =<< [pye| wide_hs |]
  pure $ a_hs == a_py
  where
    -- Convert taking range into account
    a_hs = case fromIntegral wide :: a of
      a' | fromIntegral a' == wide -> Just a'
         | otherwise               -> Nothing