recover-rtti-0.5.1: tests/Test/RecoverRTTI/Classify.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Verify we infer the right classifier
module Test.RecoverRTTI.Classify (tests) where
import Control.Monad.Except
import Data.Aeson qualified as Aeson
import Data.HashMap.Internal.Array qualified as HashMap.Array
import Data.HashMap.Lazy qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.IntMap qualified as IntMap
import Data.IntSet qualified as IntSet
import Data.Map qualified as Map
import Data.Ratio
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.SOP
import Data.Tree qualified as Tree
import Data.Type.Equality
import Data.Vector qualified as Vector.Boxed
import Data.Vector.Primitive qualified as Vector.Primitive
import Data.Vector.Storable qualified as Vector.Storable
import Unsafe.Coerce (unsafeCoerce)
#if MIN_VERSION_base(4,17,0)
import GHC.IsList qualified as IsList
#else
import GHC.Exts qualified as IsList (fromList)
#endif
import Test.Tasty
import Test.Tasty.QuickCheck (testProperty)
import Test.QuickCheck (Property)
import Test.QuickCheck qualified as QC
import Debug.RecoverRTTI
import Debug.RecoverRTTI.Classify
import Test.RecoverRTTI.ConcreteClassifier
import Test.RecoverRTTI.Globals
import Test.RecoverRTTI.Staged
import Test.RecoverRTTI.UserDefined
tests :: TestTree
tests = testGroup "Test.RecoverRTTI.Classify" [
testProperty "constants" prop_constants
, testProperty "arbitrary" prop_arbitrary
]
-- | Test using manually specified examples
--
-- For " normal " code it doesn't matter if something is generated or not,
-- but their on-heap representation may be different, and this may effect the
-- RTTI recovery.
prop_constants :: Property
prop_constants = QC.withMaxSuccess 1 $ QC.conjoin [
-- Primitive types
compareClassifier $ Value (C_Prim C_Bool) True
, compareClassifier $ Value (C_Prim C_Bool) False
, compareClassifier $ Value (C_Prim C_Char) 'a'
, compareClassifier $ Value (C_Prim C_Double) 1.25
, compareClassifier $ Value (C_Prim C_Float) 1.25
, compareClassifier $ Value (C_Prim C_Int) 1234
, compareClassifier $ Value (C_Prim C_Int) (-1234)
, compareClassifier $ Value (C_Prim C_Int8) 123
, compareClassifier $ Value (C_Prim C_Int16) 1234
, compareClassifier $ Value (C_Prim C_Int32) 1234
, compareClassifier $ Value (C_Prim C_Int64) 1234
, compareClassifier $ Value (C_Prim C_Integer) 1234
, compareClassifier $ Value (C_Prim C_Integer) (succ (fromIntegral (maxBound :: Int)))
, compareClassifier $ Value (C_Prim C_Integer) (pred (fromIntegral (minBound :: Int)))
, compareClassifier $ Value (C_Prim C_Ordering) LT
, compareClassifier $ Value (C_Prim C_Ordering) GT
, compareClassifier $ Value (C_Prim C_Ordering) EQ
, compareClassifier $ Value (C_Prim C_Unit) ()
, compareClassifier $ Value (C_Prim C_Word) 1234
, compareClassifier $ Value (C_Prim C_Word8) 123
, compareClassifier $ Value (C_Prim C_Word16) 134
, compareClassifier $ Value (C_Prim C_Word32) 1234
, compareClassifier $ Value (C_Prim C_Word64) 1234
-- String types
--
-- We skip the empty string, because we infer that as @C_List Empty@
, compareClassifier $ Value (C_Prim C_String) "abcdefg"
, compareClassifier $ Value (C_Prim C_BS_Strict) ""
, compareClassifier $ Value (C_Prim C_BS_Strict) "abcdefg"
, compareClassifier $ Value (C_Prim C_BS_Lazy) ""
, compareClassifier $ Value (C_Prim C_BS_Lazy) "abcdefg"
, compareClassifier $ Value (C_Prim C_Text_Strict) ""
, compareClassifier $ Value (C_Prim C_Text_Strict) "abcdefg"
, compareClassifier $ Value (C_Prim C_Text_Lazy) ""
, compareClassifier $ Value (C_Prim C_Text_Lazy) "abcdefg"
#if !MIN_VERSION_bytestring(0,12,0)
, compareClassifier $ Value (C_Prim C_BS_Short) ""
, compareClassifier $ Value (C_Prim C_BS_Short) "abcdefg"
#endif
-- Aeson
, compareClassifier $ Value (C_Prim C_Value) (Aeson.object [("x" Aeson..= True)])
-- Reference cells
, compareClassifier $ Value (C_Prim C_STRef) exampleIORef
, compareClassifier $ Value (C_Prim C_STRef) exampleSTRef
, compareClassifier $ Value (C_Prim C_MVar) exampleMVar
, compareClassifier $ Value (C_Prim C_TVar) exampleTVar
-- Functions
, compareClassifier $ Value (C_Prim C_Fun) (SomeFun id)
-- Containers without type arguments
, compareClassifier $ Value (C_Prim C_IntSet) $
IntSet.empty
, compareClassifier $ Value (C_Prim C_IntSet) $
IntSet.fromList [1, 2, 3]
, compareClassifier $ Value (C_Prim C_Prim_ArrayM) $
examplePrimArrayM
, compareClassifier $ Value (C_Prim C_Vector_Storable) $
SomeStorableVector $ unsafeCoerce $
Vector.Storable.fromList ([1, 2] :: [Double])
, compareClassifier $ Value (C_Prim C_Vector_StorableM) $
exampleStorableVectorM
, compareClassifier $ Value (C_Prim C_Vector_Primitive) $
SomePrimitiveVector $ unsafeCoerce $
Vector.Primitive.fromList ([1, 2] :: [Double])
, compareClassifier $ Value (C_Prim C_Vector_PrimitiveM) $
examplePrimitiveVectorM
, compareClassifier $ Value (C_Prim C_ByteArray) $
IsList.fromList [0, 1, 2]
, compareClassifier $ Value (C_Prim C_MutableByteArray) $
exampleMutableByteArray
-- Compound
, compareClassifier $ Value (C_Maybe ElemU) $
Nothing
, compareClassifier $ Value (C_Maybe (ElemK (C_Prim C_Int))) $
Just 3
, compareClassifier $ Value (C_Either (ElemKU (C_Prim C_Int))) $
Left 3
, compareClassifier $ Value (C_Either (ElemUK (C_Prim C_Bool))) $
Right True
, compareClassifier $ Value (C_List ElemU) $
[]
, compareClassifier $ Value (C_List (ElemK (C_Prim C_Int))) $
[1, 2, 3]
, compareClassifier $ Value (C_Tuple (Elems (Elem (C_Prim C_Int) :* Elem (C_Prim C_Char) :* Nil))) $
WrappedTuple (4, 'a')
, compareClassifier $ Value (C_Tuple (Elems (Elem (C_Prim C_Int) :* Elem (C_Prim C_Char) :* Elem (C_Prim C_Bool) :* Nil))) $
WrappedTuple (4, 'a', True)
, compareClassifier $ Value (C_Ratio (ElemK (C_Prim C_Integer))) $
1 % 2
, compareClassifier $ Value (C_Set ElemU) $
Set.empty
, compareClassifier $ Value (C_Set (ElemK (C_Prim C_Int))) $
Set.fromList [1, 2, 3]
, compareClassifier $ Value (C_Map ElemUU) $
Map.empty
, compareClassifier $ Value (C_Map (ElemKK (C_Prim C_Int) (C_Prim C_Char))) $
Map.fromList [(1, 'a'), (2, 'b')]
, compareClassifier $ Value (C_IntMap ElemU) $
IntMap.empty
, compareClassifier $ Value (C_IntMap (ElemK (C_Prim C_Char))) $
IntMap.fromList [(1, 'a'), (2, 'b')]
, compareClassifier $ Value (C_Sequence ElemU) $
Seq.empty
, compareClassifier $ Value (C_Sequence (ElemK (C_Prim C_Int))) $
Seq.fromList [1, 2, 3]
, compareClassifier $ Value (C_Tree (ElemK (C_Prim C_Int))) $
Tree.Node 1 []
, compareClassifier $ Value (C_HashSet (ElemK (C_Prim C_Int))) $
HashSet.fromList [1, 2, 3]
, compareClassifier $ Value (C_HashMap ElemUU) $
HashMap.empty
, compareClassifier $ Value (C_HashMap (ElemKK (C_Prim C_Int) (C_Prim C_Char))) $
HashMap.fromList [(1, 'a'), (2, 'b')]
, compareClassifier $ Value (C_HM_Array ElemU) $
HashMap.Array.fromList 0 []
, compareClassifier $ Value (C_HM_Array (ElemK (C_Prim C_Int))) $
HashMap.Array.fromList 2 [1, 2]
, compareClassifier $ Value (C_Prim_Array ElemU) $
IsList.fromList []
, compareClassifier $ Value (C_Prim_Array (ElemK (C_Prim C_Int))) $
IsList.fromList [1, 2, 3]
, compareClassifier $ Value (C_Vector_Boxed ElemU) $
Vector.Boxed.empty
, compareClassifier $ Value (C_Vector_Boxed (ElemK (C_Prim C_Int))) $
Vector.Boxed.fromList [1, 2, 3]
-- User defined
, compareClassifier $ Value (C_Other C_Simple) $
SimpleA
, compareClassifier $ Value (C_Other C_Simple) $
SimpleB
, compareClassifier $ Value (C_Other (C_NonRec ElemU)) $
(NR1 1234)
, compareClassifier $ Value (C_Other (C_NonRec (ElemK (C_Prim C_Char)))) $
(NR2 True 'a')
, compareClassifier $ Value (C_Other (C_Rec ElemU)) $
RNil
, compareClassifier $ Value (C_Other (C_Rec (ElemK (C_Prim C_Char)))) $
(RCons 'a' RNil)
, compareClassifier $ Value (C_Other C_Unlifted) $
exampleContainsUnlifted
]
where
_checkAllCases :: ConcreteClassifier a -> ()
_checkAllCases = \case
C_Prim C_Bool -> ()
C_Prim C_Char -> ()
C_Prim C_Double -> ()
C_Prim C_Float -> ()
C_Prim C_Int -> ()
C_Prim C_Int8 -> ()
C_Prim C_Int16 -> ()
C_Prim C_Int32 -> ()
C_Prim C_Int64 -> ()
C_Prim C_Integer -> ()
C_Prim C_Ordering -> ()
C_Prim C_Unit -> ()
C_Prim C_Word -> ()
C_Prim C_Word8 -> ()
C_Prim C_Word16 -> ()
C_Prim C_Word32 -> ()
C_Prim C_Word64 -> ()
-- String types
C_Prim C_String -> ()
C_Prim C_BS_Strict -> ()
C_Prim C_BS_Lazy -> ()
C_Prim C_Text_Strict -> ()
C_Prim C_Text_Lazy -> ()
#if !MIN_VERSION_bytestring(0,12,0)
C_Prim C_BS_Short -> ()
#endif
-- Aeson
C_Prim C_Value -> ()
-- Containers without type arguments
C_Prim C_IntSet -> ()
C_Prim C_Prim_ArrayM -> ()
C_Prim C_Vector_Storable -> ()
C_Prim C_Vector_StorableM -> ()
C_Prim C_Vector_Primitive -> ()
C_Prim C_Vector_PrimitiveM -> ()
C_Prim C_ByteArray -> ()
C_Prim C_MutableByteArray -> ()
-- Functions
C_Prim C_Fun -> ()
-- Reference cells
C_Prim C_STRef -> ()
C_Prim C_TVar -> ()
C_Prim C_MVar -> ()
-- Compound
C_Maybe{} -> ()
C_Either{} -> ()
C_List{} -> ()
C_Ratio{} -> ()
C_Set{} -> ()
C_Map{} -> ()
C_IntMap{} -> ()
C_Sequence{} -> ()
C_Tree{} -> ()
C_Tuple{} -> ()
C_HashSet{} -> ()
C_HashMap{} -> ()
C_HM_Array{} -> ()
C_Prim_Array{} -> ()
C_Vector_Boxed{} -> ()
-- User-defined
C_Other (C_Simple{}) -> ()
C_Other (C_NonRec{}) -> ()
C_Other (C_Rec{}) -> ()
C_Other (C_Unlifted{}) -> ()
-- | Test using arbitrary values
prop_arbitrary :: Some Value -> Property
prop_arbitrary (Some v) = compareClassifier v
-- | Compare given to inferred classifier
--
-- The tests in this module differ only in how the produce the 'Value's.
compareClassifier :: Value a -> Property
compareClassifier = \(Value cc x) ->
QC.counterexample ("Generated classifier: " ++ show cc)
$ case runExcept $ classifyConcrete x of
Left err ->
QC.counterexample ("Failed to reclassify. Error: " ++ err)
$ QC.property False
Right (Reclassified cc' _pf) ->
case sameConcrete cc cc' of
Nothing ->
QC.counterexample ("Inferred different classifier: " ++ show cc')
$ QC.property False
Just Refl ->
QC.property True