{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE AutoDeriveTypeable #-}
module HUnit (props) where
import Data.Either
import Data.Binary.Typed
import Data.Binary (Binary(..))
import Data.Typeable (Typeable)
import Test.Tasty
import Test.Tasty.HUnit
-- | Used as a dummy placeholder for fields that never carry values.
data X deriving (Typeable)
instance Binary X where
get = undefined
put = undefined
-- | The entire HUnit test tree, to be imported qualified
props :: TestTree
props = tree tests where
tree x = testGroup "HUnit" [ testGroup "Should be type errors" x ]
tests = [ error_coercions_simple_large_to_small
, error_coercions_simple_small_to_large
, error_coercions_complicated
]
-- #############################################################################
-- ### Simple bad type coercions #############################################
-- #############################################################################
-- | Decode a typed value as something else.
wackyCoercion :: (Binary a, Typeable a, Binary b, Typeable b)
=> TypeFormat
-> a
-> Either String b
wackyCoercion format value = decodeTyped (encodeTyped format value)
-- | Test whether encoding an Int and decoding it as Bool produces a type error.
-- This converts a large field (Int) to one that requires only very little
-- memory (Bool).
error_coercions_simple_large_to_small :: TestTree
error_coercions_simple_large_to_small = tree tests where
tree = testGroup "Encode Int, decode Bool"
tests = [ error_int_bool_hashed32
, error_int_bool_hashed64
, error_int_bool_shown
, error_int_bool_full
]
-- | See 'error_coercions_simple_large_to_small'
error_int_bool_hashed32 :: TestTree
error_int_bool_hashed32 =
testCase "Hashed32" $
isLeft (wackyCoercion Hashed32 (123 :: Int) :: Either String Bool)
@?
"No type error when coercing Int to Bool (with 32 bit hashed type info)"
-- | See 'error_coercions_simple_large_to_small'
error_int_bool_hashed64 :: TestTree
error_int_bool_hashed64 =
testCase "Hashed64" $
isLeft (wackyCoercion Hashed64 (123 :: Int) :: Either String Bool)
@?
"No type error when coercing Int to Bool (with 64 bit hashed type info)"
-- | See 'error_coercions_simple_large_to_small'
error_int_bool_shown :: TestTree
error_int_bool_shown =
testCase "Shown" $
isLeft (wackyCoercion Shown (123 :: Int) :: Either String Bool)
@?
"No type error when coercing Int to Bool (with shown type info)"
-- | See 'error_coercions_simple_large_to_small'
error_int_bool_full :: TestTree
error_int_bool_full =
testCase "Full" $
isLeft (wackyCoercion Full (123 :: Int) :: Either String Bool)
@?
"No type error when coercing Int to Bool (with full type info)"
-- | Test whether encoding an Int and decoding it as Bool produces a type error.
-- This converts a large field (Int) to one that requires only very little
-- memory (Bool).
error_coercions_simple_small_to_large :: TestTree
error_coercions_simple_small_to_large = tree tests where
tree = testGroup "Encode Bool, decode Int"
tests = [ error_bool_int_hashed32
, error_bool_int_hashed64
, error_bool_int_shown
, error_bool_int_full
]
-- | See 'error_coercions_simple_small_to_large'
error_bool_int_hashed32 :: TestTree
error_bool_int_hashed32 =
testCase "Hashed32" $
isLeft (wackyCoercion Hashed32 True :: Either String Int)
@?
"No type error when coercing Bool to Int (with 32 bit hashed type info)"
-- | See 'error_coercions_simple_small_to_large'
error_bool_int_hashed64 :: TestTree
error_bool_int_hashed64 =
testCase "Hashed64" $
isLeft (wackyCoercion Hashed64 True :: Either String Int)
@?
"No type error when coercing Bool to Int (with 64 bit hashed type info)"
-- | See 'error_coercions_simple_small_to_large'
error_bool_int_shown :: TestTree
error_bool_int_shown =
testCase "Shown" $
isLeft (wackyCoercion Shown True :: Either String Int)
@?
"No type error when coercing Bool to Int (with shown type info)"
-- | See 'error_coercions_simple_small_to_large'
error_bool_int_full :: TestTree
error_bool_int_full =
testCase "Full" $
isLeft (wackyCoercion Full True :: Either String Int)
@?
"No type error when coercing Bool to Int (with full type info)"
-- #############################################################################
-- ### Complicated bad type coercion #########################################
-- #############################################################################
-- | Test whether doing a coercion of a complicated type with a small
-- discrepancy produces a type error
error_coercions_complicated :: TestTree
error_coercions_complicated = tree tests where
tree = testGroup "Complicated type coercion with small discrepancy"
tests = [ error_long_type_hashed32
, error_long_type_hashed64
, error_long_type_shown
, error_long_type_full
]
-- | See 'error_coercions_complicated'
error_long_type_hashed32 :: TestTree
error_long_type_hashed32 =
testCase "Hashed32" $
isLeft (wackyCoercion Hashed32 long_type_input `asTypeOf` long_type_output)
@?
"No type error doing a complicated coercion (with 32 bit hashed type info)"
-- | See 'error_coercions_complicated'
error_long_type_hashed64 :: TestTree
error_long_type_hashed64 =
testCase "Hashed64" $
isLeft (wackyCoercion Hashed64 long_type_input `asTypeOf` long_type_output)
@?
"No type error doing a complicated coercion (with 64 bit hashed type info)"
-- | See 'error_coercions_complicated'
error_long_type_shown :: TestTree
error_long_type_shown =
testCase "Shown" $
isLeft (wackyCoercion Shown long_type_input `asTypeOf` long_type_output)
@?
"No type error doing a complicated coercion (with shown type info)"
-- | See 'error_coercions_complicated'
error_long_type_full :: TestTree
error_long_type_full =
testCase "Full" $
isLeft (wackyCoercion Full long_type_input `asTypeOf` long_type_output)
@?
"No type error doing a complicated coercion (with full type info)"
long_type_input :: (Either (Either X (), Either X (Either String X)) X, String)
long_type_input = (Left (Right (), Right (Left "hello")), "world") ------ Different types deep down
------
long_type_output :: Either String (Either (Either X (), Either X (Either Char X)) X, String)
long_type_output = error "long_type_output should never be evaluated, it is\
\ only provided for its type"