recover-rtti 0.5.3 → 0.6.1
raw patch · 27 files changed
Files
- CHANGELOG.md +39/−0
- recover-rtti.cabal +10/−7
- src/Debug/RecoverRTTI.hs +6/−6
- src/Debug/RecoverRTTI/CheckSame.hs +55/−50
- src/Debug/RecoverRTTI/Classifier.hs +66/−63
- src/Debug/RecoverRTTI/Classify.hs +97/−167
- src/Debug/RecoverRTTI/Constraint.hs +49/−24
- src/Debug/RecoverRTTI/Debugging.hs +0/−49
- src/Debug/RecoverRTTI/Reclassify.hs +42/−55
- src/Debug/RecoverRTTI/Wrappers.hs +15/−6
- tests/Test/RecoverRTTI/Classifier/Arbitrary.hs +0/−255
- tests/Test/RecoverRTTI/Classifier/Equality.hs +0/−44
- tests/Test/RecoverRTTI/Classifier/Size.hs +0/−40
- tests/Test/RecoverRTTI/Classify.hs +158/−156
- tests/Test/RecoverRTTI/ConcreteClassifier.hs +71/−200
- tests/Test/RecoverRTTI/ConcreteClassifier/Arbitrary.hs +304/−0
- tests/Test/RecoverRTTI/ConcreteClassifier/Compatibility.hs +136/−0
- tests/Test/RecoverRTTI/ConcreteClassifier/Constraint.hs +146/−0
- tests/Test/RecoverRTTI/ConcreteClassifier/Size.hs +53/−0
- tests/Test/RecoverRTTI/ConcreteClassifier/Value.hs +35/−0
- tests/Test/RecoverRTTI/Orphans.hs +44/−0
- tests/Test/RecoverRTTI/Prim.hs +1/−5
- tests/Test/RecoverRTTI/QuickCheck/DepGen.hs +6/−17
- tests/Test/RecoverRTTI/Sanity.hs +60/−24
- tests/Test/RecoverRTTI/Show.hs +28/−3
- tests/Test/RecoverRTTI/Staged.hs +18/−35
- tests/Test/RecoverRTTI/UserDefined.hs +16/−1
CHANGELOG.md view
@@ -1,5 +1,44 @@ # Revision history for recover-rtti +## 0.6.1 -- 2026-05-05++* Relax bounds on `QuickCheck` (Brandon Chinn, #55)++## 0.6.0 -- 2026-03-05++THIS IS AN IMPORTANT BUGFIX RELEASE; PLEASE UPGRADE.+Previous versions of recover-rtti may result in segfaults. Details below.++This release changes how we classify containers. In versions prior to 0.6, we+would classify a list such as `[True, False]` as `C_List (C_Prim C_Bool)`. We+did this by looking at the first element of the list, if one existed; if the+list was empty, we'd classify it as `C_List C_Void`. This is however not always+correct. Suppose we have a list of lists, and the first inner list happens to be+empty. We'd then classify the list of lists as `C_List (C_List C_Void)`, but+that is of course wrong: the next inner list might not be empty, and classifying+it as `[Void]` (and then attempting to print it) could result in segfaults.++Starting in version 0.6 we defer classification of type arguments, merely+classifying a list as `C_List`, implying that its type is `[Deferred]`. Specific+applications, such as `anythingToString`, will then recursively classify each+element prior to printing it.++We do make two exceptions to this rule:++- For lists and list-like structures, we do check if the elements are (_all_) of+ type `Char`, so that the overlapping instance `Show` for `String` (versus+ `[a]`) can be used. Not doing this would result in significantly less useful+ output from `anythingToString`.+- To distinguish `HashMap` from `HashSet` we look at the first element only. At+ least for printing this cannot result in segfaults (it would just mean that+ the values of the `HashMap` are omitted), and it's anyway exceedingly unlikely+ to happen in the first place.++Since each element is individually classified, there is no need for the+`BoxAnything` workaround anymore, which has therefore been deleted.++With thanks to Brandon Chinn for the report and the minimal reproducer (#51).+ ## 0.5.3 -- 2026-01-07 * Support `ghc-9.14` (Brandon Chinn, #48)
recover-rtti.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: recover-rtti-version: 0.5.3+version: 0.6.1 synopsis: Recover run-time type information from the GHC heap description: The main function in this package is 'classify', which looks at the GHC heap to recover type information about arbitrary@@ -22,8 +22,8 @@ GHC==9.4.8 GHC==9.6.7 GHC==9.8.4- GHC==9.10.2- GHC==9.12.2+ GHC==9.10.3+ GHC==9.12.4 GHC==9.14.1 source-repository head@@ -106,12 +106,15 @@ build-depends: recover-rtti other-modules:- Test.RecoverRTTI.Classifier.Arbitrary- Test.RecoverRTTI.Classifier.Equality- Test.RecoverRTTI.Classifier.Size Test.RecoverRTTI.Classify Test.RecoverRTTI.ConcreteClassifier+ Test.RecoverRTTI.ConcreteClassifier.Arbitrary+ Test.RecoverRTTI.ConcreteClassifier.Compatibility+ Test.RecoverRTTI.ConcreteClassifier.Constraint+ Test.RecoverRTTI.ConcreteClassifier.Size+ Test.RecoverRTTI.ConcreteClassifier.Value Test.RecoverRTTI.Globals+ Test.RecoverRTTI.Orphans Test.RecoverRTTI.Prim Test.RecoverRTTI.QuickCheck.DepGen Test.RecoverRTTI.QuickCheck.Sized@@ -135,7 +138,7 @@ build-depends: -- new dependencies- , QuickCheck >= 2.15 && < 2.17+ , QuickCheck >= 2.15 && < 2.19 , tasty >= 1.5 && < 1.6 , tasty-hunit >= 0.10 && < 0.11 , tasty-quickcheck >= 0.11 && < 0.12
src/Debug/RecoverRTTI.hs view
@@ -2,13 +2,13 @@ module Debug.RecoverRTTI ( -- * Take advantage of the recovered type information anythingToString+ , anythingToShowS -- * Debugging support -- ** Tracing , traceAnything , traceAnythingId -- ** Deriving-via , AnythingToString(..)- , BoxAnything(..) -- * Recover type information , classify , Classifier@@ -16,9 +16,10 @@ , IsUserDefined(..) -- ** Generalizations , Classifier_(..)- -- ** Unknown or partially known type arguments- , Elem(..)- , Elems(..)+ , Classifiers_(..)+ , ClassifyListElem(..)+ -- ** Deferred classification+ , Deferred(..) -- ** Newtype wrappers for unshowable types , SomeSTRef(..) , SomeTVar(..)@@ -37,8 +38,7 @@ -- ** Equality , samePrim , sameClassifier_- , sameElem- , sameElems+ , sameClassifiers_ -- * User-defined types , UserDefined -- opaque -- ** Classify constructor arguments
src/Debug/RecoverRTTI/CheckSame.hs view
@@ -4,8 +4,7 @@ -- * Check if two classifiers are the same samePrim , sameClassifier_- , sameElem- , sameElems+ , sameClassifiers_ ) where import Data.SOP@@ -43,7 +42,6 @@ -- String types - go C_String C_String = Just Refl go C_BS_Strict C_BS_Strict = Just Refl go C_BS_Lazy C_BS_Lazy = Just Refl go C_Text_Strict C_Text_Strict = Just Refl@@ -105,7 +103,6 @@ -- String types - C_String -> () C_BS_Strict -> () C_BS_Lazy -> () C_Text_Strict -> ()@@ -161,23 +158,27 @@ go (C_Prim c) (C_Prim c') = samePrim c c' go (C_Other c) (C_Other c') = sameOther c c' - -- Compound- go (C_Maybe c) (C_Maybe c') = sameElems sameOther c c' $ Refl- go (C_Either c) (C_Either c') = sameElems sameOther c c' $ Refl- go (C_List c) (C_List c') = sameElems sameOther c c' $ Refl- go (C_Ratio c) (C_Ratio c') = sameElems sameOther c c' $ Refl- go (C_Set c) (C_Set c') = sameElems sameOther c c' $ Refl- go (C_Map c) (C_Map c') = sameElems sameOther c c' $ Refl- go (C_IntMap c) (C_IntMap c') = sameElems sameOther c c' $ Refl- go (C_Sequence c) (C_Sequence c') = sameElems sameOther c c' $ Refl- go (C_Tree c) (C_Tree c') = sameElems sameOther c c' $ Refl- go (C_HashSet c) (C_HashSet c') = sameElems sameOther c c' $ Refl- go (C_HashMap c) (C_HashMap c') = sameElems sameOther c c' $ Refl- go (C_HM_Array c) (C_HM_Array c') = sameElems sameOther c c' $ Refl- go (C_Prim_Array c) (C_Prim_Array c') = sameElems sameOther c c' $ Refl- go (C_Vector_Boxed c) (C_Vector_Boxed c') = sameElems sameOther c c' $ Refl- go (C_Tuple c) (C_Tuple c') = sameElems sameOther c c' $ Refl+ -- Compound types with unclassified elements+ go C_Maybe C_Maybe = Just Refl+ go C_Ratio C_Ratio = Just Refl+ go C_Set C_Set = Just Refl+ go C_IntMap C_IntMap = Just Refl+ go C_Tree C_Tree = Just Refl+ go C_HashSet C_HashSet = Just Refl + go (C_List c) (C_List c') = listElem c c'+ go (C_Sequence c) (C_Sequence c') = listElem c c'+ go (C_HM_Array c) (C_HM_Array c') = listElem c c'+ go (C_Prim_Array c) (C_Prim_Array c') = listElem c c'+ go (C_Vector_Boxed c) (C_Vector_Boxed c') = listElem c c'++ go C_Either C_Either = Just Refl+ go C_Map C_Map = Just Refl+ go C_HashMap C_HashMap = Just Refl++ -- Compound types with classified elements+ go (C_Tuple cs) (C_Tuple cs') = sameClassifiers_ sameOther cs cs' $ Refl+ -- No match go _ _ = Nothing where@@ -188,42 +189,46 @@ C_Other{} -> () -- Compound- C_Maybe{} -> () C_Either{} -> ()+ C_HashMap{} -> ()+ C_HashSet{} -> ()+ C_HM_Array{} -> ()+ C_IntMap{} -> () C_List{} -> ()- C_Ratio{} -> ()- C_Set{} -> () C_Map{} -> ()- C_IntMap{} -> ()+ C_Maybe{} -> ()+ C_Prim_Array{} -> ()+ C_Ratio{} -> () C_Sequence{} -> ()+ C_Set{} -> () C_Tree{} -> ()- C_HashSet{} -> ()- C_HashMap{} -> ()- C_HM_Array{} -> ()- C_Prim_Array{} -> ()- C_Vector_Boxed{} -> () C_Tuple{} -> ()+ C_Vector_Boxed{} -> () -sameElem :: forall o.- (forall a b. o a -> o b -> Maybe (a :~: b))- -> (forall a b. Elem o a -> Elem o b -> Maybe (a :~: b))-sameElem sameOther = go- where- go :: Elem o a -> Elem o b -> Maybe (a :~: b)- go NoElem NoElem = Just Refl- go NoElem (Elem _) = Nothing- go (Elem _) NoElem = Nothing- go (Elem ca) (Elem cb) = sameClassifier_ sameOther ca cb+ listElem :: ClassifyListElem a -> ClassifyListElem b -> Maybe (f a :~: f b)+ listElem C_List_Deferred C_List_Deferred = Just Refl+ listElem C_List_Char C_List_Char = Just Refl+ listElem _ _ = Nothing -sameElems :: forall o r.- (forall a b. o a -> o b -> Maybe (a :~: b))- -> (forall as bs. Elems o as -> Elems o bs -> (as ~ bs => r) -> Maybe r)-sameElems sameOther = go+sameClassifiers_ :: forall o r.+ ( forall a b. o a -> o b -> Maybe (a :~: b) )+ -> ( forall as bs.+ Classifiers_ o as+ -> Classifiers_ o bs+ -> (as ~ bs => r)+ -> Maybe r+ )+sameClassifiers_ sameOther = \(Classifiers_ cs) (Classifiers_ cs') ->+ go cs cs' where- go :: Elems o as -> Elems o bs -> (as ~ bs => r) -> Maybe r- go (Elems Nil) (Elems Nil) k = Just k- go (Elems Nil) (Elems (_ :* _)) _ = Nothing- go (Elems (_ :* _)) (Elems Nil) _ = Nothing- go (Elems (c :* cs)) (Elems (c' :* cs')) k = do- Refl <- sameElem sameOther c c'- go (Elems cs) (Elems cs') k+ go ::+ NP (Classifier_ o) as+ -> NP (Classifier_ o) bs+ -> (as ~ bs => r)+ -> Maybe r+ go Nil Nil k = Just k+ go Nil (_ :* _) _ = Nothing+ go (_ :* _) Nil _ = Nothing+ go (c :* cs) (c' :* cs') k = do+ Refl <- sameClassifier_ sameOther c c'+ go cs cs' k
src/Debug/RecoverRTTI/Classifier.hs view
@@ -6,9 +6,8 @@ , IsUserDefined(..) -- * Generalizations , Classifier_(..)- -- * Nested classification- , Elem(..)- , Elems(..)+ , ClassifyListElem(..)+ , Classifiers_(..) -- * Mapping , mapClassifier ) where@@ -35,7 +34,6 @@ import Data.Text.Lazy qualified as Text.Lazy import Data.Tree (Tree) import Data.Vector qualified as Vector.Boxed-import Data.Void import Data.Word #if !MIN_VERSION_bytestring(0,12,0)@@ -56,6 +54,11 @@ -- the type of @a@ is. This is similar to a @TypeRep@, but since we recover -- this information from the heap, we have less accurate type information than -- @TypeRep@ does.+--+-- For containers only the outer shape is inferred; for example, a value of+-- type @Maybe Int@ will be classified as @C_Maybe@, implying it is of type+-- @Maybe Deferred@. Specific applications, such as 'anythingToString', then+-- depend on recursive classification for the elements. type Classifier = Classifier_ IsUserDefined -- | User-defined types@@ -89,33 +92,43 @@ C_Prim :: PrimClassifier a -> Classifier_ o a C_Other :: o a -> Classifier_ o a - -- Compound- --- -- NOTE: C_HashSet requires an argument; 'HashSet' and 'HashMap' cannot be- -- distinguished from just looking at the heap ('HashSet' is a newtype- -- around 'HashMap'), and so we classify a 'HashMap' with value type @()@- -- as a 'HashSet'; however, we can only do this of course if we have at- -- least one element.+ -- Compound types with unclassified elements - C_Maybe :: Elems o '[a] -> Classifier_ o (Maybe a)- C_Either :: Elems o '[a, b] -> Classifier_ o (Either a b)- C_List :: Elems o '[a] -> Classifier_ o [a]- C_Ratio :: Elems o '[a] -> Classifier_ o (Ratio a)- C_Set :: Elems o '[a] -> Classifier_ o (Set a)- C_Map :: Elems o '[a, b] -> Classifier_ o (Map a b)- C_IntMap :: Elems o '[a] -> Classifier_ o (IntMap a)- C_Sequence :: Elems o '[a] -> Classifier_ o (Seq a)- C_Tree :: Elems o '[a] -> Classifier_ o (Tree a)- C_HashSet :: Elems o '[a] -> Classifier_ o (HashSet a)- C_HashMap :: Elems o '[a, b] -> Classifier_ o (HashMap a b)- C_HM_Array :: Elems o '[a] -> Classifier_ o (HashMap.Array a)- C_Prim_Array :: Elems o '[a] -> Classifier_ o (Prim.Array a)- C_Vector_Boxed :: Elems o '[a] -> Classifier_ o (Vector.Boxed.Vector a)+ C_HashSet :: Classifier_ o (HashSet Deferred)+ C_IntMap :: Classifier_ o (IntMap Deferred)+ C_Maybe :: Classifier_ o (Maybe Deferred)+ C_Ratio :: Classifier_ o (Ratio Deferred)+ C_Set :: Classifier_ o (Set Deferred)+ C_Tree :: Classifier_ o (Tree Deferred) + C_HM_Array :: ClassifyListElem a -> Classifier_ o (HashMap.Array a)+ C_List :: ClassifyListElem a -> Classifier_ o [a]+ C_Prim_Array :: ClassifyListElem a -> Classifier_ o (Prim.Array a)+ C_Sequence :: ClassifyListElem a -> Classifier_ o (Seq a)+ C_Vector_Boxed :: ClassifyListElem a -> Classifier_ o (Vector.Boxed.Vector a)++ C_Either :: Classifier_ o (Either Deferred Deferred)+ C_HashMap :: Classifier_ o (HashMap Deferred Deferred)+ C_Map :: Classifier_ o (Map Deferred Deferred)++ -- Compound types with classified elements+ --+ -- We should infer type arguments /only/ if there is exactly one use of that+ -- type variable in values; in all other cases we might infer something based+ -- on the first value wihich might not be true for the other values, and+ -- therefore we should instead defer.+ C_Tuple :: (SListI xs, IsValidSize (Length xs))- => Elems o xs -> Classifier_ o (WrappedTuple xs)+ => Classifiers_ o xs -> Classifier_ o (WrappedTuple xs) +-- | Distinguish lists of characters from other lists+--+-- This ensures that we print strings as strings, rather than lists of chars.+data ClassifyListElem (a :: Type) where+ C_List_Deferred :: ClassifyListElem Deferred+ C_List_Char :: ClassifyListElem Char+ -- | Classifier for primitive types data PrimClassifier (a :: Type) where -- Primitive types@@ -144,7 +157,6 @@ -- as a list of characters). Of course, empty strings will be inferred as -- empty lists instead. - C_String :: PrimClassifier String C_BS_Strict :: PrimClassifier BS.Strict.ByteString C_BS_Lazy :: PrimClassifier BS.Lazy.ByteString C_Text_Strict :: PrimClassifier Text.Strict.Text@@ -183,31 +195,23 @@ C_ByteArray :: PrimClassifier Prim.ByteArray C_MutableByteArray :: PrimClassifier SomeMutableByteArray -{-------------------------------------------------------------------------------- Nested classification--------------------------------------------------------------------------------}--data Elem o a where- Elem :: Classifier_ o a -> Elem o a- NoElem :: Elem o Void--newtype Elems o xs = Elems (NP (Elem o) xs)+newtype Classifiers_ o xs = Classifiers_ (NP (Classifier_ o) xs) {------------------------------------------------------------------------------- Show -------------------------------------------------------------------------------} -deriving instance Show (PrimClassifier a)+deriving instance Show (PrimClassifier a)+deriving instance Show (ClassifyListElem a) deriving instance (forall x. Show (o x)) => Show (Classifier_ o a)-deriving instance (forall x. Show (o x)) => Show (Elem o a) -instance (forall a. Show (o a), SListI xs) => Show (Elems o xs) where- showsPrec p (Elems xs) =+instance (forall a. Show (o a), SListI xs) => Show (Classifiers_ o xs) where+ showsPrec p (Classifiers_ xs) = case all_NP allShow of Dict -> showsPrec p xs where- allShow :: NP (Dict (Compose Show (Elem o))) xs+ allShow :: NP (Dict (Compose Show (Classifier_ o))) xs allShow = hpure Dict {-------------------------------------------------------------------------------@@ -221,32 +225,31 @@ mapClassifier other = go where go :: forall a. Classifier_ o a -> m (Classifier_ o' a)- -- Primitive and user-defined types + -- Primitive and user-defined types go (C_Prim c) = pure (C_Prim c) go (C_Other c) = C_Other <$> other c - -- Compound+ -- Compound types with unclassified elements+ go C_HashSet = pure C_HashSet+ go C_IntMap = pure C_IntMap+ go C_Maybe = pure C_Maybe+ go C_Ratio = pure C_Ratio+ go C_Set = pure C_Set+ go C_Tree = pure C_Tree - go (C_Maybe c) = C_Maybe <$> goElems c- go (C_Either c) = C_Either <$> goElems c- go (C_List c) = C_List <$> goElems c- go (C_Ratio c) = C_Ratio <$> goElems c- go (C_Set c) = C_Set <$> goElems c- go (C_Map c) = C_Map <$> goElems c- go (C_IntMap c) = C_IntMap <$> goElems c- go (C_Sequence c) = C_Sequence <$> goElems c- go (C_Tree c) = C_Tree <$> goElems c- go (C_HashSet c) = C_HashSet <$> goElems c- go (C_HashMap c) = C_HashMap <$> goElems c- go (C_HM_Array c) = C_HM_Array <$> goElems c- go (C_Prim_Array c) = C_Prim_Array <$> goElems c- go (C_Vector_Boxed c) = C_Vector_Boxed <$> goElems c- go (C_Tuple c) = C_Tuple <$> goElems c+ go (C_HM_Array c) = pure (C_HM_Array c)+ go (C_List c) = pure (C_List c)+ go (C_Prim_Array c) = pure (C_Prim_Array c)+ go (C_Sequence c) = pure (C_Sequence c)+ go (C_Vector_Boxed c) = pure (C_Vector_Boxed c) - goElems :: SListI xs => Elems o xs -> m (Elems o' xs)- goElems (Elems cs) = Elems <$> htraverse' goElem cs+ go C_Either = pure C_Either+ go C_HashMap = pure C_HashMap+ go C_Map = pure C_Map - goElem :: Elem o a -> m (Elem o' a)- goElem (Elem c) = Elem <$> go c- goElem NoElem = pure NoElem+ -- Compound types with classified elements+ go (C_Tuple cs) = C_Tuple <$> goNP cs++ goNP :: SListI xs => Classifiers_ o xs -> m (Classifiers_ o' xs)+ goNP (Classifiers_ cs) = Classifiers_ <$> htraverse' go cs
src/Debug/RecoverRTTI/Classify.hs view
@@ -12,16 +12,10 @@ , fromUserDefined -- * Showing values , anythingToString+ , anythingToShowS , canShowPrim , canShowClassified , canShowClassified_- -- * Patterns for common shapes of 'Elems' (exported for the tests)- , pattern ElemK- , pattern ElemU- , pattern ElemKK- , pattern ElemUU- , pattern ElemKU- , pattern ElemUK ) where import Control.Monad@@ -32,21 +26,12 @@ import Data.HashMap.Internal.Array qualified as HashMap.Array import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy qualified as HashMap-import Data.IntMap (IntMap)-import Data.Map (Map)-import Data.Map qualified as Map import Data.Primitive.Array qualified as Prim (Array)-import Data.Primitive.Array qualified as Prim.Array import Data.Sequence (Seq)-import Data.Set (Set) import Data.SOP import Data.SOP.Dict-import Data.Tree (Tree)-import Data.Tree qualified as Tree import Data.Vector qualified as Vector.Boxed-import Data.Void import GHC.Exts.Heap (Closure)-import GHC.Real import System.IO.Unsafe (unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) @@ -140,15 +125,15 @@ -- Maybe (inKnownModule GhcMaybe -> Just "Nothing") ->- mustBe <$> classifyMaybe (unsafeCoerce x)+ return $ mustBe C_Maybe (inKnownModule GhcMaybe -> Just "Just") ->- mustBe <$> classifyMaybe (unsafeCoerce x)+ return $ mustBe C_Maybe -- Either (inKnownModule DataEither -> Just "Left") ->- mustBe <$> classifyEither (unsafeCoerce x)+ return $ mustBe C_Either (inKnownModule DataEither -> Just "Right") ->- mustBe <$> classifyEither (unsafeCoerce x)+ return $ mustBe C_Either -- Lists (this includes the 'String' case) (inKnownModule GhcTypes -> Just "[]") ->@@ -158,19 +143,19 @@ -- Ratio (inKnownModule GhcReal -> Just ":%") ->- mustBe <$> classifyRatio (unsafeCoerce x)+ return $ mustBe C_Ratio -- Set (inKnownModule DataSetInternal -> Just "Tip") ->- mustBe <$> classifySet (unsafeCoerce x)+ return $ mustBe C_Set (inKnownModule DataSetInternal -> Just "Bin") ->- mustBe <$> classifySet (unsafeCoerce x)+ return $ mustBe C_Set -- Map (inKnownModule DataMapInternal -> Just "Tip") ->- mustBe <$> classifyMap (unsafeCoerce x)+ return $ mustBe C_Map (inKnownModule DataMapInternal -> Just "Bin") ->- mustBe <$> classifyMap (unsafeCoerce x)+ return $ mustBe C_Map -- IntSet (inKnownModule DataIntSetInternal -> Just "Bin") ->@@ -182,11 +167,11 @@ -- IntMap (inKnownModule DataIntMapInternal -> Just "Nil") ->- mustBe <$> classifyIntMap (unsafeCoerce x)+ return $ mustBe C_IntMap (inKnownModule DataIntMapInternal -> Just "Tip") ->- mustBe <$> classifyIntMap (unsafeCoerce x)+ return $ mustBe C_IntMap (inKnownModule DataIntMapInternal -> Just "Bin") ->- mustBe <$> classifyIntMap (unsafeCoerce x)+ return $ mustBe C_IntMap -- Sequence (inKnownModule DataSequenceInternal -> Just "EmptyT") ->@@ -198,7 +183,7 @@ -- Tree (inKnownModule DataTree -> Just "Node") ->- mustBe <$> classifyTree (unsafeCoerce x)+ return $ mustBe C_Tree -- Tuples (of size 2..62) (inKnownModuleNested GhcTuple -> Just (@@ -247,7 +232,7 @@ -- Boxed vectors (inKnownModule DataVector -> Just "Vector") ->- mustBe <$> classifyVectorBoxed (unsafeCoerce x)+ mustBe <$> classifyBoxedVector (unsafeCoerce x) -- Storable vectors (inKnownModule DataVectorStorable -> Just "Vector") ->@@ -304,162 +289,99 @@ classify = unsafePerformIO . runExceptT . classifyIO {-------------------------------------------------------------------------------- Classification for compound types--------------------------------------------------------------------------------}--classifyMaybe :: Maybe a -> ExceptT Closure IO (Classifier (Maybe a))-classifyMaybe = classifyFoldable C_Maybe+ List elements -classifyEither ::- Either a b- -> ExceptT Closure IO (Classifier (Either a b))-classifyEither x =- case x of- Left x' -> (mustBe . C_Either . ElemKU) <$> classifyIO x'- Right y' -> (mustBe . C_Either . ElemUK) <$> classifyIO y'+ We add a special case for @[Char]@, so that that @show@ will use the+ (overlapped) instance for @String@ instead of the general instance for @[a]@.+ We cannot recognize this for empty lists, but printing those as @[]@ is OK. We+ must do this not only for lists proper, but also for datatypes where the+ 'Show' instance piggy-backs on the instance for lists. -classifyList :: [a] -> ExceptT Closure IO (Classifier [a])-classifyList = classifyFoldable c_list- where- -- We special case for @String@, so that @show@ will use the (overlapped)- -- instance for @String@ instead of the general instance for @[a]@- c_list :: Elems o '[x] -> Classifier_ o [x]- c_list (ElemK (C_Prim C_Char)) = C_Prim C_String- c_list c = C_List c+ We must however be careful with list(-like)s of 'Any', where the first+ character happens tob be a 'Char'. We therefore check /all/ elements.+-------------------------------------------------------------------------------} -classifyRatio :: Ratio a -> ExceptT Closure IO (Classifier (Ratio a))-classifyRatio (x' :% _) = mustBe . C_Ratio . ElemK <$> classifyIO x'+type ClassifyListLike f = forall a. f a -> ExceptT Closure IO (Classifier (f a)) -classifySet :: Set a -> ExceptT Closure IO (Classifier (Set a))-classifySet = classifyFoldable C_Set+classifyListLike :: forall f.+ (forall a. ClassifyListElem a -> Classifier_ IsUserDefined (f a))+ -> (forall a. f a -> [a])+ -> ClassifyListLike f+classifyListLike cf toList = \xs ->+ -- If the container is empty, we have a choice. It is however /probably/+ -- more confusing to display a non-string as a string (albeit empty) than+ -- the other way around.+ case toList xs of+ [] -> return $ mustBe $ cf C_List_Deferred+ x:xs' -> go (x:xs')+ where+ -- Check every element+ --+ -- Precondition: all elements /already/ considered must all be 'Char'.+ go :: [a] -> ExceptT Closure IO (Classifier (f a))+ go [] = return $ mustBe $ cf C_List_Char+ go (x:xs) = do+ cx <- classifyIO x+ case cx of+ C_Prim C_Char -> go xs+ _otherwise -> return $ mustBe $ cf C_List_Deferred -classifyMap :: Map a b -> ExceptT Closure IO (Classifier (Map a b))-classifyMap = classifyFoldablePair C_Map Map.toList+classifyBoxedVector :: ClassifyListLike Vector.Boxed.Vector+classifyHMArray :: ClassifyListLike HashMap.Array+classifyPrimArray :: ClassifyListLike Prim.Array+classifyList :: ClassifyListLike []+classifySequence :: ClassifyListLike Seq -classifyIntMap :: IntMap a -> ExceptT Closure IO (Classifier (IntMap a))-classifyIntMap = classifyFoldable C_IntMap+classifyBoxedVector = classifyListLike C_Vector_Boxed Foldable.toList+classifyHMArray = classifyListLike C_HM_Array HashMap.Array.toList+classifyPrimArray = classifyListLike C_Prim_Array Foldable.toList+classifyList = classifyListLike C_List id+classifySequence = classifyListLike C_Sequence Foldable.toList -classifySequence :: Seq a -> ExceptT Closure IO (Classifier (Seq a))-classifySequence = classifyFoldable C_Sequence+{-------------------------------------------------------------------------------+ HashMap -classifyTree :: Tree a -> ExceptT Closure IO (Classifier (Tree a))-classifyTree (Tree.Node x' _) = mustBe . C_Tree . ElemK <$> classifyIO x'+ 'HashSet' and 'HashMap' cannot be distinguished from just looking at the heap+ , because 'HashSet' is a newtype around 'HashMap'. Instead, we classify a+ 'HashMap' with value type @()@ as a 'HashSet'. -classifyHashMap :: HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))-classifyHashMap = classifyFoldablePair c_hashmap HashMap.toList- where- -- HashSet is a newtype around HashMap- c_hashmap :: Elems o '[x, y] -> Classifier_ o (HashMap x y)- c_hashmap (ElemKK c (C_Prim C_Unit)) = mustBe $ C_HashSet (ElemK c)- c_hashmap c = C_HashMap c+ In princple we /should/ look at all elements (like we do for list-like+ containers). However, it is extremely unlikely that we will a HashMap of+ 'Any', where the first value happens to be of type @()@. Moreover, if it+ /does/ happen, the only consequence is that we omit the values (printing the+ keys as a set); no segfault can happen (and we test this). We therefore look+ simply at the first element only.+-------------------------------------------------------------------------------} -classifyHMArray ::- HashMap.Array a- -> ExceptT Closure IO (Classifier (HashMap.Array a))-classifyHMArray =- classifyArrayLike- C_HM_Array- HashMap.Array.length- hmHead+-- | Classify 'HashMap'+--+-- We try to recognize 'HashSet', if we can.+classifyHashMap ::+ HashMap a b+ -> ExceptT Closure IO (Classifier (HashMap a b))+classifyHashMap xs =+ case HashMap.elems xs of+ [] -> return $ mustBe C_HashMap+ x:_ -> aux <$> classifyIO x where- hmHead a = case HashMap.Array.index# a 0 of (# x #) -> x--classifyPrimArray ::- Prim.Array a- -> ExceptT Closure IO (Classifier (Prim.Array a))-classifyPrimArray =- classifyArrayLike- C_Prim_Array- Prim.Array.sizeofArray- (`Prim.Array.indexArray` 0)+ aux :: Classifier b -> Classifier (HashMap a b)+ aux (C_Prim C_Unit) = mustBe C_HashSet+ aux _otherwise = mustBe C_HashMap -classifyVectorBoxed ::- Vector.Boxed.Vector a- -> ExceptT Closure IO (Classifier (Vector.Boxed.Vector a))-classifyVectorBoxed =- classifyArrayLike- C_Vector_Boxed- Vector.Boxed.length- Vector.Boxed.head+{-------------------------------------------------------------------------------+ Classifying tuples+-------------------------------------------------------------------------------} classifyTuple :: (SListI xs, IsValidSize (Length xs)) => NP (K Box) xs -> ExceptT Closure IO (Classifier (WrappedTuple xs)) classifyTuple ptrs = do- cs <- hsequence' (hmap aux ptrs)- return $ C_Tuple (Elems (hmap Elem cs))+ C_Tuple . Classifiers_ <$> hsequence' (hmap aux ptrs) where aux :: K Box a -> (ExceptT Closure IO :.: Classifier) a aux (K (Box x)) = Comp $ classifyIO (unsafeCoerce x) -{-------------------------------------------------------------------------------- Helper functions for defining classifiers--------------------------------------------------------------------------------}--classifyFoldable ::- Foldable f- => (forall o x. Elems o '[x] -> Classifier_ o (f x))- -> f a -> ExceptT Closure IO (Classifier (f a))-classifyFoldable cc x =- case Foldable.toList x of- [] -> return $ mustBe $ cc ElemU- x':_ -> mustBe . cc . ElemK <$> classifyIO x'--classifyFoldablePair ::- (forall o x y. Elems o '[x, y] -> Classifier_ o (f x y))- -> (f a b -> [(a, b)])- -> f a b -> ExceptT Closure IO (Classifier (f a b))-classifyFoldablePair cc toList x =- case toList x of- [] -> return $ mustBe $ cc ElemUU- (x', y'):_ -> (\ca cb -> mustBe $ cc (ElemKK ca cb))- <$> classifyIO x'- <*> classifyIO y'--classifyArrayLike ::- (forall o x. Elems o '[x] -> Classifier_ o (f x))- -> (f a -> Int) -- ^ Get the length of the array- -> (f a -> a) -- ^ Get the first element (provided the array is not empty)- -> f a -> ExceptT Closure IO (Classifier (f a))-classifyArrayLike cc getLen getFirst x =- if getLen x == 0- then return $ mustBe $ cc ElemU- else do- let x' = getFirst x- mustBe . cc . ElemK <$> classifyIO x'--{-------------------------------------------------------------------------------- Patterns for common shapes of 'Elems'-- This is mostly useful internally; we export these only for the benefit of the- QuickCheck generator. Most other code can treat the all types uniformly.-- We distinguish between which elements are (K)nown and which (U)nknown--------------------------------------------------------------------------------}--pattern ElemK :: Classifier_ o a -> Elems o '[a]-pattern ElemK c = Elems (Elem c :* Nil)--pattern ElemU :: Elems o '[Void]-pattern ElemU = Elems (NoElem :* Nil)--pattern ElemKK :: Classifier_ o a -> Classifier_ o b -> Elems o '[a, b]-pattern ElemKK ca cb = Elems (Elem ca :* Elem cb :* Nil)--pattern ElemUU :: Elems o '[Void, Void]-pattern ElemUU = Elems (NoElem :* NoElem :* Nil)--pattern ElemKU :: Classifier_ o a -> Elems o '[a, Void]-pattern ElemKU c = Elems (Elem c :* NoElem :* Nil)--pattern ElemUK :: Classifier_ o b -> Elems o '[Void, b]-pattern ElemUK c = Elems (NoElem :* Elem c :* Nil)--{-------------------------------------------------------------------------------- Recognizing tuples--------------------------------------------------------------------------------}- isTuple :: String -> Maybe (Some ValidSize) isTuple typ = do (a, xs, z) <- dropEnds typ@@ -519,12 +441,17 @@ -- -- If classification fails, we show the actual closure. anythingToString :: forall a. a -> String-anythingToString x =+anythingToString x = anythingToShowS 0 x ""++-- | Generalization of 'anythingToString' with user-specified precedence+anythingToShowS :: forall a. Int -> a -> ShowS+anythingToShowS p x = case classify x of- Left closure -> show closure+ Left closure -> showsPrec p closure Right classifier -> case canShowClassified classifier of- Dict -> show x+ Dict -> showsPrec p x + deriving instance Show (Some Classified) instance Show (Classified a) where@@ -567,3 +494,6 @@ $ xs where (constrName, args) = fromUserDefined x++instance Show Deferred where+ showsPrec = anythingToShowS
src/Debug/RecoverRTTI/Constraint.hs view
@@ -30,7 +30,6 @@ import Data.Text.Lazy qualified as Text.Lazy import Data.Tree (Tree) import Data.Vector qualified as Vector.Boxed-import Data.Void import Data.Word #if !MIN_VERSION_bytestring(0,12,0)@@ -134,7 +133,6 @@ -- String types - go C_String = Dict go C_BS_Strict = Dict go C_BS_Lazy = Dict go C_Text_Strict = Dict@@ -217,7 +215,7 @@ ) => ClassifiedSatisfies (c :: Type -> Constraint) classifiedSatisfies :: forall c o.- (ClassifiedSatisfies c, c Void)+ (ClassifiedSatisfies c, c Deferred) => (forall a. o a -> Dict c a) -> (forall a. Classifier_ o a -> Dict c a) classifiedSatisfies otherSatisfies = go@@ -226,26 +224,53 @@ go (C_Prim c) = primSatisfies c go (C_Other c) = otherSatisfies c - -- Compound- go (C_Maybe c) = goElems c $ Dict- go (C_Either c) = goElems c $ Dict- go (C_List c) = goElems c $ Dict- go (C_Ratio c) = goElems c $ Dict- go (C_Set c) = goElems c $ Dict- go (C_Map c) = goElems c $ Dict- go (C_IntMap c) = goElems c $ Dict- go (C_Sequence c) = goElems c $ Dict- go (C_Tree c) = goElems c $ Dict- go (C_HashSet c) = goElems c $ Dict- go (C_HashMap c) = goElems c $ Dict- go (C_HM_Array c) = goElems c $ Dict- go (C_Prim_Array c) = goElems c $ Dict- go (C_Vector_Boxed c) = goElems c $ Dict- go (C_Tuple c) = goElems c $ Dict+ -- Compound types with unclassified elements+ go C_Maybe = Dict+ go C_Ratio = Dict+ go C_Set = Dict+ go C_IntMap = Dict+ go C_Tree = Dict+ go C_HashSet = Dict - goElems :: SListI as => Elems o as -> (All c as => r) -> r- goElems (Elems cs) k = case all_NP (hmap goElem cs) of Dict -> k+ go (C_HM_Array c) = goHMArray c+ go (C_List c) = goList c+ go (C_Prim_Array c) = goPrimArray c+ go (C_Sequence c) = goSequence c+ go (C_Vector_Boxed c) = goVectorBoxed c - goElem :: Elem o a -> Dict c a- goElem (Elem c) = go c- goElem NoElem = Dict+ go C_Either = Dict+ go C_HashMap = Dict+ go C_Map = Dict++ -- Compound types with classified elements+ go (C_Tuple cs) = goNP cs Dict++ goNP :: SListI as => Classifiers_ o as -> (All c as => r) -> r+ goNP (Classifiers_ cs) k = case all_NP (hmap go cs) of Dict -> k++ --+ -- For list-like types we must explicitly, monomorphically, consider the+ -- 'Char' case separately, so that instance resolution can correctly deal+ -- with the overlapping instances.+ --++ goHMArray :: ClassifyListElem a -> Dict c (HashMap.Array a)+ goList :: ClassifyListElem a -> Dict c [a]+ goPrimArray :: ClassifyListElem a -> Dict c (Prim.Array a)+ goSequence :: ClassifyListElem a -> Dict c (Seq a)+ goVectorBoxed :: ClassifyListElem a -> Dict c (Vector.Boxed.Vector a)++ goList C_List_Deferred = Dict+ goList C_List_Char = Dict++ goHMArray C_List_Deferred = Dict+ goHMArray C_List_Char = Dict++ goVectorBoxed C_List_Deferred = Dict+ goVectorBoxed C_List_Char = Dict++ goSequence C_List_Deferred = Dict+ goSequence C_List_Char = Dict++ goPrimArray C_List_Deferred = Dict+ goPrimArray C_List_Char = Dict
src/Debug/RecoverRTTI/Debugging.hs view
@@ -5,7 +5,6 @@ , traceAnythingId -- * Deriving-via support , AnythingToString(..)- , BoxAnything(..) ) where import Debug.Trace@@ -45,51 +44,3 @@ instance Show (AnythingToString a) where show (AnythingToString x) = anythingToString x --- | Add level of indirection on the heap------ (Advanced users only, for most use cases this should not be necessary.)------ Type recovery in @recover-rtti@ (through 'classify') works by looking at the--- values on the heap. For example, if we see a list, we then look at the first--- element of that list (if any), and if that element happens to be an 'Int',--- the inferred type is @[Int]@. When we show such a list ('anythingToString'),--- every element of the list is interpreted as an 'Int', without doing further--- type recovery.------ This works for normal use cases, but fails in low-level code that uses 'Any'--- to squeeze values of different types into a data structure not designed for--- that purpose. For example, consider------ > data T f = T [f Any]------ If we call 'anythingToString' on a 'T' value with elements of different--- types in the list, we get some unexpected results:------ > anythingToString (T [unsafeCoerce (1 :: Int), unsafeCoerce False])--- > == "T [1,14355032]"------ The reason is that the type of the list was inferred as @[Int]@, and hence--- the 'Bool' was subsequently also interpreted as an 'Int'.------ 'BoxAnything' helps to resolve the problem. There are ways in which it can--- be used. First, we can derive the following entirely reasonable 'Show'--- instance for 'T':------ > deriving instance Show a => Show (T (K a))------ We then get------ > show (T [K $ BoxAnything (1 :: Int), K $ BoxAnything False])--- > == "T [K 1,K False]"------ Alternatively, we can omit the 'Show' instance for 'T', to get------ > anythingToString (T [K $ BoxAnything (1 :: Int), K $ BoxAnything False])--- > == "T [BoxAnything 1,BoxAnything False]"------ For this second use case to work, it is critical that 'BoxAnything' is a--- datatype, not a newtype, so that it actually appears on the heap.-data BoxAnything = forall a. BoxAnything a--instance Show BoxAnything where- show (BoxAnything x) = anythingToString x
src/Debug/RecoverRTTI/Reclassify.hs view
@@ -36,7 +36,7 @@ data ReclassifiedElems o as where RElems :: (SListI bs, Length bs ~ Length as)- => Elems o bs -> PairWise FromUsr as bs -> ReclassifiedElems o as+ => Classifiers_ o bs -> PairWise FromUsr as bs -> ReclassifiedElems o as reclassify_ :: forall m o o'. Applicative m => (forall a. o a -> m (Reclassified o' a))@@ -48,75 +48,62 @@ -- Given a classifier with user-defined classifiers at the levels, along with -- coercion functions, leave the user-defined classifiers in place but lift the -- coercion function to the top-level.-distribReclassified :: forall o.- (forall a. Classifier_ (Reclassified o) a -> Reclassified (Classifier_ o) a)+distribReclassified :: forall o a.+ Classifier_ (Reclassified o) a+ -> Reclassified (Classifier_ o) a distribReclassified = go where- go :: forall a. Classifier_ (Reclassified o) a -> Reclassified (Classifier_ o) a- -- Primitive and user-defined+ go :: forall x. Classifier_ (Reclassified o) x -> Reclassified (Classifier_ o) x++ -- Primitive and user-defined types+ go (C_Prim c) = Reclassified (C_Prim c) Id go (C_Other c) = case c of Reclassified c' f -> Reclassified (C_Other c') f - -- Compound- go (C_Maybe c) = go1 C_Maybe c- go (C_Either c) = go2 C_Either c- go (C_List c) = go1 C_List c- go (C_Ratio c) = go1 C_Ratio c- go (C_Set c) = go1 C_Set c- go (C_Map c) = go2 C_Map c- go (C_IntMap c) = go1 C_IntMap c- go (C_Sequence c) = go1 C_Sequence c- go (C_Tree c) = go1 C_Tree c- go (C_HashSet c) = go1 C_HashSet c- go (C_HashMap c) = go2 C_HashMap c- go (C_HM_Array c) = go1 C_HM_Array c- go (C_Prim_Array c) = go1 C_Prim_Array c- go (C_Vector_Boxed c) = go1 C_Vector_Boxed c- go (C_Tuple c) = goN C_Tuple c+ -- Compound types with unclassified elements+ go C_HashSet = Reclassified C_HashSet Id+ go C_IntMap = Reclassified C_IntMap Id+ go C_Maybe = Reclassified C_Maybe Id+ go C_Ratio = Reclassified C_Ratio Id+ go C_Set = Reclassified C_Set Id+ go C_Tree = Reclassified C_Tree Id - go1 :: forall f a.- (forall a'. Elems o '[a'] -> Classifier_ o (f a'))- -> Elems (Reclassified o) '[a]- -> Reclassified (Classifier_ o) (f a)- go1 cf c =- case distribElems c of- RElems c' (PCons f PNil) -> Reclassified (cf c') (F1 f)+ go (C_HM_Array c) = Reclassified (C_HM_Array c) Id+ go (C_List c) = Reclassified (C_List c) Id+ go (C_Prim_Array c) = Reclassified (C_Prim_Array c) Id+ go (C_Sequence c) = Reclassified (C_Sequence c) Id+ go (C_Vector_Boxed c) = Reclassified (C_Vector_Boxed c) Id - go2 :: forall f a b.- (forall a' b'. Elems o '[a', b'] -> Classifier_ o (f a' b'))- -> Elems (Reclassified o) '[a, b]- -> Reclassified (Classifier_ o) (f a b)- go2 cf c =- case distribElems c of- RElems c' (PCons f (PCons f' PNil)) -> Reclassified (cf c') (F2 f f')+ go C_Either = Reclassified C_Either Id+ go C_HashMap = Reclassified C_HashMap Id+ go C_Map = Reclassified C_Map Id - goN :: forall f as.- SListI as- => (forall as'.- (SListI as', Length as' ~ Length as)- => Elems o as' -> Classifier_ o (f as'))- -> Elems (Reclassified o) as- -> Reclassified (Classifier_ o) (f as)+ -- Compound types with classified elements+ go (C_Tuple cs) = goN C_Tuple cs++ goN :: forall f xs.+ SListI xs+ => (forall xs'.+ (SListI xs', Length xs' ~ Length xs)+ => Classifiers_ o xs' -> Classifier_ o (f xs'))+ -> Classifiers_ (Reclassified o) xs+ -> Reclassified (Classifier_ o) (f xs) goN cf c = case distribElems c of RElems c' fs -> Reclassified (cf c') (FN fs) -distribElem :: Elem (Reclassified o) a -> Reclassified (Elem o) a-distribElem = \case- NoElem -> Reclassified NoElem Absurd- Elem c -> case distribReclassified c of- Reclassified c' f -> Reclassified (Elem c') f- distribElems :: SListI xs- => Elems (Reclassified o) xs -> ReclassifiedElems o xs-distribElems = \(Elems cs) -> go $ hmap distribElem cs+ => Classifiers_ (Reclassified o) xs -> ReclassifiedElems o xs+distribElems = \(Classifiers_ cs) -> go $ hmap distribReclassified cs where- go :: NP (Reclassified (Elem o)) xs -> ReclassifiedElems o xs- go Nil = RElems (Elems Nil) PNil- go (Reclassified c f :* cs) = case go cs of- RElems (Elems cs') fs' ->- RElems (Elems (c :* cs')) (PCons f fs')+ go :: NP (Reclassified (Classifier_ o)) xs -> ReclassifiedElems o xs+ go Nil = RElems (Classifiers_ Nil) PNil+ go (Reclassified c f :* cs) =+ case go cs of+ RElems (Classifiers_ cs') fs' ->+ RElems (Classifiers_ (c :* cs')) (PCons f fs')+ {------------------------------------------------------------------------------- Evidence that we are only doing conversions from Any
src/Debug/RecoverRTTI/Wrappers.hs view
@@ -12,8 +12,9 @@ -- nonetheless stil useful, as it means that we can show /everything/, which is -- kind of the point. module Debug.RecoverRTTI.Wrappers (- -- * User-defined types- UserDefined(..)+ -- * Deferred classification and user-defined types+ Deferred(..)+ , UserDefined(..) -- * Functions , SomeFun(..) -- * Reference cells@@ -37,14 +38,22 @@ import GHC.Exts {-------------------------------------------------------------------------------- User-defined types+ Deferred classification and user-defined types -------------------------------------------------------------------------------} +-- | As-yet-unknown type+--+-- See t'Debug.RecoverRTTI.Classifier' for detailed discussion.+newtype Deferred = Deferred Any+ -- | User-defined type ----- We defer classification of the arguments to the constructor (the type might--- be recursive, so if we tried to classify all arguments, we might end up--- unrolling the recursion at the type level).+-- We tried to infer a type, but it's a type that is not explicitly recognized+-- by @recover-rtti@. Such values will be printed using a generic "constructor+-- with arguments" approach.+--+-- If desired, domain specific type inference can be done; see+-- 'Debug.RecoverRTTI.reclassify_'. newtype UserDefined = UserDefined Any {-------------------------------------------------------------------------------
− tests/Test/RecoverRTTI/Classifier/Arbitrary.hs
@@ -1,255 +0,0 @@-{-# LANGUAGE CPP #-}--module Test.RecoverRTTI.Classifier.Arbitrary (arbitraryClassifier_) where--import Data.Bifunctor-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.Kind-import Data.Map qualified as Map-import Data.Sequence qualified as Seq-import Data.Set qualified as Set-import Data.SOP-import Data.Tree (Tree)-import Data.Tree qualified as Tree-import Data.Vector qualified as Vector.Boxed-import Data.Void-import GHC.Real (Ratio((:%)))--#if MIN_VERSION_base(4,17,0)-import GHC.IsList qualified as IsList-#else-import GHC.Exts qualified as IsList (fromList)-#endif--import Debug.RecoverRTTI-import Debug.RecoverRTTI.Classify--import Test.QuickCheck (Gen)--import Test.RecoverRTTI.Classifier.Equality ()-import Test.RecoverRTTI.Prim-import Test.RecoverRTTI.QuickCheck.DepGen-import Test.RecoverRTTI.QuickCheck.Sized (SizedGen)-import Test.RecoverRTTI.QuickCheck.Sized qualified as SG--{-------------------------------------------------------------------------------- Generate arbitiary classifiers--------------------------------------------------------------------------------}---- | Generated arbitrary classifier along with a generator for that value------ NOTE: The " size " here refers to the size of the /classifier/. Along with--- the classifier we construct a generator for values of the corresponding--- type; that generator in turn has its own (independent) size parameter.-arbitraryClassifier_ :: forall c o.- (c ~ Classifier_ o)- => SizedGen (Some (DepGen o)) -> SizedGen (Some (DepGen c))-arbitraryClassifier_ genOther = go- where- go :: SizedGen (Some (DepGen c))- go = SG.leafOrStep leaf compound-- -- Leaves of the tree (values with no recursion).- --- -- We will fail to generate a leaf when the size reaches 0; this ensures- -- termination.- leaf :: Gen (Some (DepGen c))- leaf = do- Some c <- arbitraryPrimClassifier- return $ Some $ primDepGen c-- -- Compound- --- -- We deduct one from the size for the outer-most constructor- --- -- For most types we generate arbitrary subtypes, but for some types we- -- must pick subtypes satisfying a certain constraint (e.g., @Ord@ for- -- @Set@); for such types we just pick a single example.- compound :: [SizedGen (Some (DepGen c))]- compound = [- -- We include " other " in the compound list, so that we are sure- -- to subtract one from the size- (\(Some (DepGen c gen)) -> Some (DepGen (C_Other c) gen)) <$> genOther-- , go_U_K C_Maybe Nothing- (mapSome (GenK (fmap Just)) <$> go)-- , go_KU_UK C_Either- (mapSome (GenKU (fmap Left)) <$> go)- (mapSome (GenUK (fmap Right)) <$> go)-- -- @[Char]@ is classified as @String@- , let notChar (Some (DepGen (C_Prim C_Char) _)) = False- notChar _otherwise = True in- go_U_K C_List []- (mapSome (GenK (SG.genListLike id)) <$> (go `SG.suchThat` notChar))-- , go_K C_Ratio $ pure . Some $ GenK {- justGen = \g -> uncurry (:%) <$> SG.divvyPair g g- , justElem = primDepGen C_Int- }-- , go_U_K C_Set Set.empty $ pure . Some $ GenK {- justGen = SG.genListLike Set.fromList- , justElem = primDepGen C_Int- }-- , go_UU_KK C_Map Map.empty- ((\(Some genElem) -> Some $ GenKK {- pairGen = SG.genMapLike Map.fromList- , pairFst = primDepGen C_Int- , pairSnd = genElem- }) <$> go)-- , go_U_K C_IntMap IntMap.empty- ((\(Some genElem) -> Some $ GenK {- justGen = SG.genMapLike IntMap.fromList SG.arbitrary- , justElem = genElem- }) <$> go)-- , go_U_K C_Sequence Seq.empty- (mapSome (GenK (SG.genListLike Seq.fromList)) <$> go)-- , go_K C_Tree- (mapSome (GenK (SG.genListLike mkSomeTree)) <$> go)-- , go_K C_HashSet $ pure . Some $ GenK {- justGen = SG.genListLike HashSet.fromList- , justElem = primDepGen C_Int- }-- -- @HashMap a ()@ is classified as a @HashSet@ instead- , let notUnit (Some (DepGen (C_Prim C_Unit) _)) = False- notUnit _otherwise = True in- go_UU_KK C_HashMap HashMap.empty- ((\(Some genElem) -> Some $ GenKK {- pairGen = SG.genMapLike HashMap.fromList- , pairFst = primDepGen C_Int- , pairSnd = genElem- }) <$> (go `SG.suchThat` notUnit))-- , let mkArray xs = HashMap.Array.fromList (length xs) xs in- go_U_K C_HM_Array (mkArray [])- (mapSome (GenK (SG.genListLike mkArray)) <$> go)-- , go_U_K C_Prim_Array (IsList.fromList [])- (mapSome (GenK (SG.genListLike IsList.fromList)) <$> go)-- , go_U_K C_Vector_Boxed Vector.Boxed.empty- (mapSome (GenK (SG.genListLike Vector.Boxed.fromList)) <$> go)-- , goTuple- ]-- go_K :: forall f.- ( forall x. Show x => Show (f x)- , forall x. Eq x => Eq (f x)- )- => (forall x. Elems o '[x] -> c (f x))- -> SizedGen (Some (GenK c f))- -> SizedGen (Some (DepGen c))- go_K cf = fmap (\(Some a) -> Some (genJust (cf . ElemK) a))-- go_U_K :: forall f.- ( forall x. Show x => Show (f x)- , forall x. Eq x => Eq (f x)- )- => (forall x. Elems o '[x] -> c (f x))- -> f Void- -> SizedGen (Some (GenK c f))- -> SizedGen (Some (DepGen c))- go_U_K cf nothing just =- SG.leafOrStep- (pure $ Some $ DepGen (cf ElemU) (pure nothing))- [(\(Some a) -> Some (genJust (cf . ElemK) a)) <$> just]-- go_KU_UK :: forall f.- ( forall x y. (Show x, Show y) => Show (f x y)- , forall x y. (Eq x, Eq y) => Eq (f x y)- )- => (forall x y. Elems o '[x, y] -> c (f x y))- -> SizedGen (Some (GenKU c f))- -> SizedGen (Some (GenUK c f))- -> SizedGen (Some (DepGen c))- go_KU_UK cf left right =- SG.oneofStepped [- (\(Some a) -> Some (genLeft (cf . ElemKU) a)) <$> left- , (\(Some b) -> Some (genRight (cf . ElemUK) b)) <$> right- ]-- go_UU_KK :: forall (f :: Type -> Type -> Type).- ( forall x y. (Show x, Show y) => Show (f x y)- , forall x y. (Eq x, Eq y) => Eq (f x y)- )- => (forall x y. Elems o '[x, y] -> c (f x y))- -> f Void Void- -> SizedGen (Some (GenKK c f))- -> SizedGen (Some (DepGen c))- go_UU_KK cf nothing just =- SG.leafOrStep- (pure $ Some $ DepGen (cf ElemUU) (pure nothing))- [(\(Some ab@GenKK{}) -> Some (genPair (cf . uncurry ElemKK) ab)) <$> just]-- goTuple :: SizedGen (Some (DepGen c))- goTuple =- (\(Some (SG.ValidTuple t)) -> Some (lift t)) <$> SG.genTuple go- where- lift :: (SListI xs, IsValidSize (Length xs))- => NP (DepGen (Classifier_ o)) xs- -> DepGen (Classifier_ o) (WrappedTuple xs)- lift t = genNP (C_Tuple . Elems . hmap Elem) $ GenNP {- npGen = fmap tupleFromNP . hsequence- , npElem = t- }-- _checkAllCases :: Classifier_ o a -> ()- _checkAllCases = \case- -- Primitive and user-defined- C_Prim{} -> ()- C_Other{} -> ()-- -- Compound- C_Maybe{} -> ()- C_Either{} -> ()- C_List{} -> ()- C_Ratio{} -> ()- C_Set{} -> ()- C_Map{} -> ()- C_IntMap{} -> ()- C_Sequence{} -> ()- C_Tree{} -> ()- C_HashSet{} -> ()- C_HashMap{} -> ()- C_HM_Array{} -> ()- C_Prim_Array{} -> ()- C_Vector_Boxed{} -> ()- C_Tuple{} -> ()--{-------------------------------------------------------------------------------- Auxiliary tree functions--------------------------------------------------------------------------------}--mkSomeTree :: [a] -> Tree a-mkSomeTree [] = error "mkSomeTree: empty"-mkSomeTree [x] = Tree.Node x []-mkSomeTree [x, y] = Tree.Node x [Tree.Node y []]-mkSomeTree (x : xs) =- let (left, right) = split xs- in Tree.Node x [mkSomeTree left, mkSomeTree right]---- | Split list into halves------ If the input has at least two elements, neither list will be empty------ > split "abcde" == ("ace","bd")-split :: [a] -> ([a], [a])-split [] = ([], [])-split (x:xs) = first (x:) $ splot xs---- | Auxiliary to 'split'-splot :: [a] -> ([a], [a])-splot [] = ([], [])-splot (x:xs) = second (x:) $ split xs
− tests/Test/RecoverRTTI/Classifier/Equality.hs
@@ -1,44 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}---- | Equality orphan instances-module Test.RecoverRTTI.Classifier.Equality () where--import Data.Function (on)-import Data.HashMap.Internal.Array qualified as HashMap (Array)-import Data.HashMap.Internal.Array qualified as HashMap.Array--import Debug.RecoverRTTI--{-------------------------------------------------------------------------------- Reasonable instances--------------------------------------------------------------------------------}--instance Eq a => Eq (HashMap.Array a) where- (==) = (==) `on` HashMap.Array.toList--{-------------------------------------------------------------------------------- Degenerate instances-- It is (obviously!) important that these are available in the test suite only.--------------------------------------------------------------------------------}--instance Eq SomeFun where- _ == _ = True--instance Eq SomePrimArrayM where- _ == _ = True--instance Eq SomeStorableVector where- _ == _ = True--instance Eq SomeStorableVectorM where- _ == _ = True--instance Eq SomePrimitiveVector where- _ == _ = True--instance Eq SomePrimitiveVectorM where- _ == _ = True--instance Eq SomeMutableByteArray where- _ == _ = True
− tests/Test/RecoverRTTI/Classifier/Size.hs
@@ -1,40 +0,0 @@-module Test.RecoverRTTI.Classifier.Size (classifierSize_) where--import Data.SOP--import Debug.RecoverRTTI--{-------------------------------------------------------------------------------- Size--------------------------------------------------------------------------------}--classifierSize_ :: forall o.- (forall a. o a -> Int)- -> (forall a. Classifier_ o a -> Int)-classifierSize_ sizeOther = go- where- go :: Classifier_ o a -> Int- go (C_Prim _) = 1- go (C_Other c) = sizeOther c- go (C_Maybe c) = 1 + goElems c- go (C_Either c) = 1 + goElems c- go (C_List c) = 1 + goElems c- go (C_Ratio c) = 1 + goElems c- go (C_Set c) = 1 + goElems c- go (C_Map c) = 1 + goElems c- go (C_IntMap c) = 1 + goElems c- go (C_Sequence c) = 1 + goElems c- go (C_Tree c) = 1 + goElems c- go (C_HashSet c) = 1 + goElems c- go (C_HashMap c) = 1 + goElems c- go (C_HM_Array c) = 1 + goElems c- go (C_Prim_Array c) = 1 + goElems c- go (C_Vector_Boxed c) = 1 + goElems c- go (C_Tuple c) = 1 + goElems c-- goElems :: SListI as => Elems o as -> Int- goElems (Elems cs) = sum . hcollapse $ hmap (K . goElem) cs-- goElem :: Elem o a -> Int- goElem NoElem = 0- goElem (Elem c) = go c
tests/Test/RecoverRTTI/Classify.hs view
@@ -17,10 +17,13 @@ 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 Test.QuickCheck (Property)+import Test.QuickCheck qualified as QC+import Test.Tasty+import Test.Tasty.QuickCheck (testProperty) import Unsafe.Coerce (unsafeCoerce) #if MIN_VERSION_base(4,17,0)@@ -29,18 +32,14 @@ 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.ConcreteClassifier.Value import Test.RecoverRTTI.Globals import Test.RecoverRTTI.Staged import Test.RecoverRTTI.UserDefined+import Test.RecoverRTTI.ConcreteClassifier.Compatibility tests :: TestTree tests = testGroup "Test.RecoverRTTI.Classify" [@@ -48,275 +47,277 @@ , testProperty "arbitrary" prop_arbitrary ] +withNumTests :: QC.Testable prop => Int -> prop -> Property+#if MIN_VERSION_QuickCheck(2,18,0)+withNumTests = QC.withNumTests+#else+withNumTests = QC.withMaxSuccess+#endif+ -- | 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 [+prop_constants = withNumTests 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+ compareClassifier $ Value (CC_Prim C_Bool) True+ , compareClassifier $ Value (CC_Prim C_Bool) False+ , compareClassifier $ Value (CC_Prim C_Char) 'a'+ , compareClassifier $ Value (CC_Prim C_Double) 1.25+ , compareClassifier $ Value (CC_Prim C_Float) 1.25+ , compareClassifier $ Value (CC_Prim C_Int) 1234+ , compareClassifier $ Value (CC_Prim C_Int) (-1234)+ , compareClassifier $ Value (CC_Prim C_Int8) 123+ , compareClassifier $ Value (CC_Prim C_Int16) 1234+ , compareClassifier $ Value (CC_Prim C_Int32) 1234+ , compareClassifier $ Value (CC_Prim C_Int64) 1234+ , compareClassifier $ Value (CC_Prim C_Integer) 1234+ , compareClassifier $ Value (CC_Prim C_Integer) (succ (fromIntegral (maxBound :: Int)))+ , compareClassifier $ Value (CC_Prim C_Integer) (pred (fromIntegral (minBound :: Int)))+ , compareClassifier $ Value (CC_Prim C_Ordering) LT+ , compareClassifier $ Value (CC_Prim C_Ordering) GT+ , compareClassifier $ Value (CC_Prim C_Ordering) EQ+ , compareClassifier $ Value (CC_Prim C_Unit) ()+ , compareClassifier $ Value (CC_Prim C_Word) 1234+ , compareClassifier $ Value (CC_Prim C_Word8) 123+ , compareClassifier $ Value (CC_Prim C_Word16) 134+ , compareClassifier $ Value (CC_Prim C_Word32) 1234+ , compareClassifier $ Value (CC_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"+ , compareClassifier $ Value (CC_Prim C_BS_Strict) ""+ , compareClassifier $ Value (CC_Prim C_BS_Strict) "abcdefg"+ , compareClassifier $ Value (CC_Prim C_BS_Lazy) ""+ , compareClassifier $ Value (CC_Prim C_BS_Lazy) "abcdefg"+ , compareClassifier $ Value (CC_Prim C_Text_Strict) ""+ , compareClassifier $ Value (CC_Prim C_Text_Strict) "abcdefg"+ , compareClassifier $ Value (CC_Prim C_Text_Lazy) ""+ , compareClassifier $ Value (CC_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"+ , compareClassifier $ Value (CC_Prim C_BS_Short) ""+ , compareClassifier $ Value (CC_Prim C_BS_Short) "abcdefg" #endif -- Aeson - , compareClassifier $ Value (C_Prim C_Value) (Aeson.object [("x" Aeson..= True)])+ , compareClassifier $ Value (CC_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+ , compareClassifier $ Value (CC_Prim C_STRef) exampleIORef+ , compareClassifier $ Value (CC_Prim C_STRef) exampleSTRef+ , compareClassifier $ Value (CC_Prim C_MVar) exampleMVar+ , compareClassifier $ Value (CC_Prim C_TVar) exampleTVar -- Functions - , compareClassifier $ Value (C_Prim C_Fun) (SomeFun id)+ , compareClassifier $ Value (CC_Prim C_Fun) (SomeFun id) -- Containers without type arguments - , compareClassifier $ Value (C_Prim C_IntSet) $+ , compareClassifier $ Value (CC_Prim C_IntSet) $ IntSet.empty- , compareClassifier $ Value (C_Prim C_IntSet) $+ , compareClassifier $ Value (CC_Prim C_IntSet) $ IntSet.fromList [1, 2, 3] - , compareClassifier $ Value (C_Prim C_Prim_ArrayM) $+ , compareClassifier $ Value (CC_Prim C_Prim_ArrayM) $ examplePrimArrayM - , compareClassifier $ Value (C_Prim C_Vector_Storable) $+ , compareClassifier $ Value (CC_Prim C_Vector_Storable) $ SomeStorableVector $ unsafeCoerce $ Vector.Storable.fromList ([1, 2] :: [Double]) - , compareClassifier $ Value (C_Prim C_Vector_StorableM) $+ , compareClassifier $ Value (CC_Prim C_Vector_StorableM) $ exampleStorableVectorM - , compareClassifier $ Value (C_Prim C_Vector_Primitive) $+ , compareClassifier $ Value (CC_Prim C_Vector_Primitive) $ SomePrimitiveVector $ unsafeCoerce $ Vector.Primitive.fromList ([1, 2] :: [Double]) - , compareClassifier $ Value (C_Prim C_Vector_PrimitiveM) $+ , compareClassifier $ Value (CC_Prim C_Vector_PrimitiveM) $ examplePrimitiveVectorM - , compareClassifier $ Value (C_Prim C_ByteArray) $+ , compareClassifier $ Value (CC_Prim C_ByteArray) $ IsList.fromList [0, 1, 2]- , compareClassifier $ Value (C_Prim C_MutableByteArray) $+ , compareClassifier $ Value (CC_Prim C_MutableByteArray) $ exampleMutableByteArray -- Compound - , compareClassifier $ Value (C_Maybe ElemU) $+ , compareClassifier $ Value (CC_Maybe CC_Void) $ Nothing- , compareClassifier $ Value (C_Maybe (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_Maybe (CC_Prim C_Int)) $ Just 3 - , compareClassifier $ Value (C_Either (ElemKU (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_Either (CC_Prim C_Int) CC_Void) $ Left 3- , compareClassifier $ Value (C_Either (ElemUK (C_Prim C_Bool))) $+ , compareClassifier $ Value (CC_Either CC_Void (CC_Prim C_Bool)) $ Right True - , compareClassifier $ Value (C_List ElemU) $+ , compareClassifier $ Value (CC_List CC_Void) $ []- , compareClassifier $ Value (C_List (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_List (CC_Prim C_Int)) $ [1, 2, 3] - , compareClassifier $ Value (C_Tuple (Elems (Elem (C_Prim C_Int) :* Elem (C_Prim C_Char) :* Nil))) $+ , compareClassifier $ Value (CC_Tuple (Concretes (CC_Prim C_Int :* CC_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))) $+ , compareClassifier $ Value (CC_Tuple (Concretes (CC_Prim C_Int :* CC_Prim C_Char :* CC_Prim C_Bool :* Nil))) $ WrappedTuple (4, 'a', True) - , compareClassifier $ Value (C_Ratio (ElemK (C_Prim C_Integer))) $+ , compareClassifier $ Value (CC_Ratio (CC_Prim C_Integer)) $ 1 % 2 - , compareClassifier $ Value (C_Set ElemU) $+ , compareClassifier $ Value (CC_Set CC_Void) $ Set.empty- , compareClassifier $ Value (C_Set (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_Set (CC_Prim C_Int)) $ Set.fromList [1, 2, 3] - , compareClassifier $ Value (C_Map ElemUU) $+ , compareClassifier $ Value (CC_Map CC_Void CC_Void) $ Map.empty- , compareClassifier $ Value (C_Map (ElemKK (C_Prim C_Int) (C_Prim C_Char))) $+ , compareClassifier $ Value (CC_Map (CC_Prim C_Int) (CC_Prim C_Char)) $ Map.fromList [(1, 'a'), (2, 'b')] - , compareClassifier $ Value (C_IntMap ElemU) $+ , compareClassifier $ Value (CC_IntMap CC_Void) $ IntMap.empty- , compareClassifier $ Value (C_IntMap (ElemK (C_Prim C_Char))) $+ , compareClassifier $ Value (CC_IntMap (CC_Prim C_Char)) $ IntMap.fromList [(1, 'a'), (2, 'b')] - , compareClassifier $ Value (C_Sequence ElemU) $+ , compareClassifier $ Value (CC_Sequence CC_Void) $ Seq.empty- , compareClassifier $ Value (C_Sequence (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_Sequence (CC_Prim C_Int)) $ Seq.fromList [1, 2, 3] - , compareClassifier $ Value (C_Tree (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_Tree (CC_Prim C_Int)) $ Tree.Node 1 [] - , compareClassifier $ Value (C_HashSet (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_HashSet (CC_Prim C_Int)) $ HashSet.fromList [1, 2, 3] - , compareClassifier $ Value (C_HashMap ElemUU) $+ , compareClassifier $ Value (CC_HashMap CC_Void CC_Void) $ HashMap.empty- , compareClassifier $ Value (C_HashMap (ElemKK (C_Prim C_Int) (C_Prim C_Char))) $+ , compareClassifier $ Value (CC_HashMap (CC_Prim C_Int) (CC_Prim C_Char)) $ HashMap.fromList [(1, 'a'), (2, 'b')] - , compareClassifier $ Value (C_HM_Array ElemU) $+ , compareClassifier $ Value (CC_HM_Array CC_Void) $ HashMap.Array.fromList 0 []- , compareClassifier $ Value (C_HM_Array (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_HM_Array (CC_Prim C_Int)) $ HashMap.Array.fromList 2 [1, 2] - , compareClassifier $ Value (C_Prim_Array ElemU) $+ , compareClassifier $ Value (CC_Prim_Array CC_Void) $ IsList.fromList []- , compareClassifier $ Value (C_Prim_Array (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_Prim_Array (CC_Prim C_Int)) $ IsList.fromList [1, 2, 3] - , compareClassifier $ Value (C_Vector_Boxed ElemU) $+ , compareClassifier $ Value (CC_Vector_Boxed CC_Void) $ Vector.Boxed.empty- , compareClassifier $ Value (C_Vector_Boxed (ElemK (C_Prim C_Int))) $+ , compareClassifier $ Value (CC_Vector_Boxed (CC_Prim C_Int)) $ Vector.Boxed.fromList [1, 2, 3] -- User defined - , compareClassifier $ Value (C_Other C_Simple) $+ , compareClassifier $ Value (CC_Other CC_Simple) $ SimpleA- , compareClassifier $ Value (C_Other C_Simple) $+ , compareClassifier $ Value (CC_Other CC_Simple) $ SimpleB - , compareClassifier $ Value (C_Other (C_NonRec ElemU)) $+ , compareClassifier $ Value (CC_Other (CC_NonRec CC_Void)) $ (NR1 1234)- , compareClassifier $ Value (C_Other (C_NonRec (ElemK (C_Prim C_Char)))) $+ , compareClassifier $ Value (CC_Other (CC_NonRec (CC_Prim C_Char))) $ (NR2 True 'a') - , compareClassifier $ Value (C_Other (C_Rec ElemU)) $+ , compareClassifier $ Value (CC_Other (CC_Rec CC_Void)) $ RNil- , compareClassifier $ Value (C_Other (C_Rec (ElemK (C_Prim C_Char)))) $+ , compareClassifier $ Value (CC_Other (CC_Rec (CC_Prim C_Char))) $ (RCons 'a' RNil) - , compareClassifier $ Value (C_Other C_Unlifted) $+ , compareClassifier $ Value (CC_Other CC_Unlifted) $ exampleContainsUnlifted ] where- _checkAllCases :: ConcreteClassifier a -> ()+ _checkAllCases :: Concrete 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 -> ()+ -- Void (used only as an argument to containers)+ CC_Void -> () - -- String types+ -- Primitive types+ CC_Prim C_Bool -> ()+ CC_Prim C_Char -> ()+ CC_Prim C_Double -> ()+ CC_Prim C_Float -> ()+ CC_Prim C_Int -> ()+ CC_Prim C_Int8 -> ()+ CC_Prim C_Int16 -> ()+ CC_Prim C_Int32 -> ()+ CC_Prim C_Int64 -> ()+ CC_Prim C_Integer -> ()+ CC_Prim C_Ordering -> ()+ CC_Prim C_Unit -> ()+ CC_Prim C_Word -> ()+ CC_Prim C_Word8 -> ()+ CC_Prim C_Word16 -> ()+ CC_Prim C_Word32 -> ()+ CC_Prim C_Word64 -> () - C_Prim C_String -> ()- C_Prim C_BS_Strict -> ()- C_Prim C_BS_Lazy -> ()- C_Prim C_Text_Strict -> ()- C_Prim C_Text_Lazy -> ()+ -- String types+ CC_Prim C_BS_Strict -> ()+ CC_Prim C_BS_Lazy -> ()+ CC_Prim C_Text_Strict -> ()+ CC_Prim C_Text_Lazy -> () #if !MIN_VERSION_bytestring(0,12,0)- C_Prim C_BS_Short -> ()+ CC_Prim C_BS_Short -> () #endif -- Aeson-- C_Prim C_Value -> ()+ CC_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 -> ()+ CC_Prim C_IntSet -> ()+ CC_Prim C_Prim_ArrayM -> ()+ CC_Prim C_Vector_Storable -> ()+ CC_Prim C_Vector_StorableM -> ()+ CC_Prim C_Vector_Primitive -> ()+ CC_Prim C_Vector_PrimitiveM -> ()+ CC_Prim C_ByteArray -> ()+ CC_Prim C_MutableByteArray -> () -- Functions-- C_Prim C_Fun -> ()+ CC_Prim C_Fun -> () -- Reference cells-- C_Prim C_STRef -> ()- C_Prim C_TVar -> ()- C_Prim C_MVar -> ()+ CC_Prim C_STRef -> ()+ CC_Prim C_TVar -> ()+ CC_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{} -> ()+ CC_Either{} -> ()+ CC_HashMap{} -> ()+ CC_HashSet{} -> ()+ CC_HM_Array{} -> ()+ CC_IntMap{} -> ()+ CC_List{} -> ()+ CC_Map{} -> ()+ CC_Maybe{} -> ()+ CC_Prim_Array{} -> ()+ CC_Ratio{} -> ()+ CC_Sequence{} -> ()+ CC_Set{} -> ()+ CC_Tree{} -> ()+ CC_Tuple{} -> ()+ CC_Vector_Boxed{} -> () -- User-defined-- C_Other (C_Simple{}) -> ()- C_Other (C_NonRec{}) -> ()- C_Other (C_Rec{}) -> ()- C_Other (C_Unlifted{}) -> ()+ CC_Other (CC_Simple{}) -> ()+ CC_Other (CC_NonRec{}) -> ()+ CC_Other (CC_Rec{}) -> ()+ CC_Other (CC_Unlifted{}) -> () -- | Test using arbitrary values prop_arbitrary :: Some Value -> Property@@ -333,9 +334,10 @@ QC.counterexample ("Failed to reclassify. Error: " ++ err) $ QC.property False Right (Reclassified cc' _pf) ->- case sameConcrete cc cc' of+ case compatibleClassifier cc cc' of Nothing -> QC.counterexample ("Inferred different classifier: " ++ show cc') $ QC.property False- Just Refl ->+ Just _ -> QC.property True+
tests/Test/RecoverRTTI/ConcreteClassifier.hs view
@@ -1,228 +1,99 @@ module Test.RecoverRTTI.ConcreteClassifier ( -- * Concrete classifier- ConcreteClassifier- , ClassifyUser(..)- -- * Values- , Value(..)- -- * Constraints- , canShowConcrete- , canCompareConcrete- -- * Size- , sizeUser- , sizeConcrete- -- * Same classifier- , sameUser- , sameConcrete- -- * Equality- -- * Arbitrary- , arbitraryUser- , arbitraryConcrete+ Concrete(..)+ , ConcreteUser(..)+ , Concretes(..) ) where import Data.Kind import Data.SOP import Data.SOP.Dict-import Data.Type.Equality import Data.Void+import Data.HashMap.Internal.Array qualified as HashMap (Array)+import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet)+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Primitive.Array qualified as Prim (Array)+import Data.Ratio+import Data.Sequence (Seq)+import Data.Set (Set)+import Data.Tree (Tree)+import Data.Vector qualified as Vector.Boxed import Debug.RecoverRTTI-import Debug.RecoverRTTI.Classify -import Test.QuickCheck (Arbitrary(..), Gen)-import Test.QuickCheck qualified as QC--import Test.RecoverRTTI.Classifier.Arbitrary-import Test.RecoverRTTI.Classifier.Equality ()-import Test.RecoverRTTI.Classifier.Size-import Test.RecoverRTTI.QuickCheck.DepGen-import Test.RecoverRTTI.QuickCheck.Sized (SizedGen)-import Test.RecoverRTTI.QuickCheck.Sized qualified as SG import Test.RecoverRTTI.UserDefined {------------------------------------------------------------------------------- Concrete classifier-- The difference between the " concrete " classifier and the 'Classifier' from- the main library is that the former has explicit cases for user-defined types,- and the latter doesn't (merely classifying them as 'UserDefined').-- In "Test.RecoverRRTI.Staged" we show that we can do staged inference,- using 'classify' repeatedly to recover /all/ (concrete) type information- from the type information returned by 'classify' (/if/ we have full- information about which user-defined types we're interested in). -------------------------------------------------------------------------------} -type ConcreteClassifier = Classifier_ ClassifyUser--data ClassifyUser (a :: Type) where- C_Simple :: ClassifyUser SimpleType- C_NonRec :: Elems ClassifyUser '[a] -> ClassifyUser (NonRecursive a)- C_Rec :: Elems ClassifyUser '[a] -> ClassifyUser (Recursive a)- C_Unlifted :: ClassifyUser ContainsUnlifted--deriving instance Show (ClassifyUser a)--{-------------------------------------------------------------------------------- Values--------------------------------------------------------------------------------}---- | Like 'Classified', but using 'ConcreteClassifier'+-- | Concrete classifier ----- For convenience, we also include some constraints here, even though they--- are in fact derivable from the classifier-data Value a where- Value :: (Show a, Eq a) => ConcreteClassifier a -> a -> Value a--deriving instance Show (Value a)-deriving instance Show (Some Value)--instance Arbitrary (Some Value) where- arbitrary = do- -- We don't want to generate large classifiers- Some (DepGen cc gen) <- SG.run 10 arbitraryConcrete-- -- For the values however we want to be able to generate larger trees- Some . Value cc <$> SG.run 1000 gen--{-------------------------------------------------------------------------------- Constraints--------------------------------------------------------------------------------}--class (- c SimpleType- , forall a. c a => c (NonRecursive a)- , forall a. c a => c (Recursive a)- , c ContainsUnlifted- ) => UserSatisfies c--instance (- c SimpleType- , forall a. c a => c (NonRecursive a)- , forall a. c a => c (Recursive a)- , c ContainsUnlifted- ) => UserSatisfies c--userSatisfies :: forall c.- (ClassifiedSatisfies c, c Void, UserSatisfies c)- => (forall a. ClassifyUser a -> Dict c a)-userSatisfies = go- where- go :: ClassifyUser a -> Dict c a- go C_Simple = Dict- go (C_NonRec c) = goElems c $ Dict- go (C_Rec c) = goElems c $ Dict- go C_Unlifted = Dict-- goElems :: SListI as => Elems ClassifyUser as -> (All c as => r) -> r- goElems (Elems cs) k = case all_NP (hmap goElem cs) of Dict -> k-- goElem :: Elem ClassifyUser a -> Dict c a- goElem (Elem c) = concreteSatisfies c- goElem NoElem = Dict--concreteSatisfies ::- (ClassifiedSatisfies c, c Void, UserSatisfies c)- => ConcreteClassifier a -> Dict c a-concreteSatisfies = classifiedSatisfies userSatisfies--canShowConcrete :: ConcreteClassifier a -> Dict Show a-canShowConcrete = concreteSatisfies--canCompareConcrete :: ConcreteClassifier a -> Dict Eq a-canCompareConcrete = concreteSatisfies--{-------------------------------------------------------------------------------- Size of the classifier-- Mostly used for sanity checking the generator--------------------------------------------------------------------------------}--sizeUser :: ClassifyUser a -> Int-sizeUser = go- where- go :: ClassifyUser a -> Int- go C_Simple = 1- go (C_NonRec c) = 1 + goElems c- go (C_Rec c) = 1 + goElems c- go C_Unlifted = 1-- goElems :: SListI as => Elems ClassifyUser as -> Int- goElems (Elems cs) = sum . hcollapse $ hmap (K . goElem) cs-- goElem :: Elem ClassifyUser a -> Int- goElem NoElem = 0- goElem (Elem c) = sizeConcrete c--sizeConcrete :: ConcreteClassifier a -> Int-sizeConcrete = classifierSize_ sizeUser--{-------------------------------------------------------------------------------- Same classifier--------------------------------------------------------------------------------}+-- The differences between the \"concrete\" classifier 'Concrete' and the+-- 'Classifier' from the main library are+--+-- * 'Concrete' has explicit cases for user-defined types,+-- whereas `Classifier` merely classifying them as 'UserDefined'`+-- * 'Concrete' does not have any \"deferred\" types+--+-- The constructor names intentionally line up exactly with the main library.+--+-- In "Test.RecoverRRTI.Staged" we show that we can do staged inference,+-- using 'classify' repeatedly to recover /all/ (concrete) type information+-- from the type information returned by 'classify' (/if/ we have full+-- information about which user-defined types we're interested in).+data Concrete (a :: Type) :: Type where+ -- Primitive and user-defined types+ CC_Prim :: PrimClassifier a -> Concrete a+ CC_Other :: ConcreteUser a -> Concrete a --- | Check that two classifiers are the same-sameConcrete ::- ConcreteClassifier a- -> ConcreteClassifier b- -> Maybe (a :~: b)-sameConcrete = sameClassifier_ sameUser+ -- Void+ --+ -- We use this when generating elements of empty types+ CC_Void :: Concrete Void -sameUser :: ClassifyUser a -> ClassifyUser b -> Maybe (a :~: b)-sameUser = go- where- go :: ClassifyUser a -> ClassifyUser b -> Maybe (a :~: b)- go C_Simple C_Simple = Just Refl- go (C_NonRec c) (C_NonRec c') = sameElems sameUser c c' $ Refl- go (C_Rec c) (C_Rec c') = sameElems sameUser c c' $ Refl- go C_Unlifted C_Unlifted = Just Refl- go _ _ = Nothing+ -- Compound types with unclassified elements in 'Classifier'+ CC_HashSet :: Concrete a -> Concrete (HashSet a)+ CC_IntMap :: Concrete a -> Concrete (IntMap a)+ CC_Maybe :: Concrete a -> Concrete (Maybe a)+ CC_Ratio :: Concrete a -> Concrete (Ratio a)+ CC_Set :: Concrete a -> Concrete (Set a)+ CC_Tree :: Concrete a -> Concrete (Tree a) - _checkAllCases :: ClassifyUser a -> ()- _checkAllCases = \case- C_Simple{} -> ()- C_NonRec{} -> ()- C_Rec{} -> ()- C_Unlifted{} -> ()+ CC_HM_Array :: Concrete a -> Concrete (HashMap.Array a)+ CC_List :: Concrete a -> Concrete [a]+ CC_Prim_Array :: Concrete a -> Concrete (Prim.Array a)+ CC_Sequence :: Concrete a -> Concrete (Seq a)+ CC_Vector_Boxed :: Concrete a -> Concrete (Vector.Boxed.Vector a) -{-------------------------------------------------------------------------------- Arbitrary--------------------------------------------------------------------------------}+ CC_Either :: Concrete a -> Concrete b -> Concrete (Either a b)+ CC_HashMap :: Concrete a -> Concrete b -> Concrete (HashMap a b)+ CC_Map :: Concrete a -> Concrete b -> Concrete (Map a b) -arbitraryUser :: SizedGen (Some (DepGen ClassifyUser))-arbitraryUser = SG.leafOrStep leaf compound- where- leaf :: Gen (Some (DepGen ClassifyUser))- leaf = QC.oneof [- -- SimpleType- pure . Some $ arbitraryDepGen C_Simple+ -- Compound types which have classified elements even in 'Classifier' - -- ContainsUnlifted- , pure . Some $ arbitraryDepGen C_Unlifted- ]+ CC_Tuple ::+ (SListI xs, IsValidSize (Length xs))+ => Concretes xs -> Concrete (WrappedTuple xs) - compound :: [SizedGen (Some (DepGen ClassifyUser))]- compound = [- -- NonRecursive- go_U_K C_NonRec (NR1 1234)- (mapSome (GenK (fmap (NR2 True))) <$> arbitraryConcrete)+newtype Concretes xs = Concretes (NP Concrete xs) - -- Recursive- , go_U_K C_Rec RNil- (mapSome (GenK (SG.genListLike recursiveFromList)) <$> arbitraryConcrete)- ]+-- | Example user-defined types+data ConcreteUser (a :: Type) where+ CC_Simple :: ConcreteUser SimpleType+ CC_NonRec :: Concrete a -> ConcreteUser (NonRecursive a)+ CC_Rec :: Concrete a -> ConcreteUser (Recursive a)+ CC_Unlifted :: ConcreteUser ContainsUnlifted - go_U_K ::- ( forall x. Show x => Show (f x)- , forall x. Eq x => Eq (f x)- )- => (forall a. Elems ClassifyUser '[a] -> ClassifyUser (f a))- -> f Void- -> SizedGen (Some (GenK ConcreteClassifier f))- -> SizedGen (Some (DepGen ClassifyUser))- go_U_K cf nothing just =- SG.leafOrStep- (pure $ Some $ DepGen (cf ElemU) (pure nothing))- [(\(Some a) -> Some (genJust (cf . ElemK) a)) <$> just]+deriving instance Show (Concrete a)+deriving instance Show (ConcreteUser a) -arbitraryConcrete :: SizedGen (Some (DepGen ConcreteClassifier))-arbitraryConcrete = arbitraryClassifier_ arbitraryUser+instance SListI xs => Show (Concretes xs) where+ showsPrec p (Concretes xs) =+ case all_NP allShow of+ Dict -> showsPrec p xs+ where+ allShow :: NP (Dict (Compose Show Concrete)) xs+ allShow = hpure Dict
+ tests/Test/RecoverRTTI/ConcreteClassifier/Arbitrary.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE CPP #-}++module Test.RecoverRTTI.ConcreteClassifier.Arbitrary (+ arbitraryConcrete+ ) where++import Data.Kind+import Data.SOP+import Data.SOP.Dict+import Data.Tree (Tree)+import Data.Vector qualified as Vector.Boxed+import Data.Void+import Test.QuickCheck (Gen)+import Test.QuickCheck qualified as QC++import Data.Bifunctor+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.Map qualified as Map+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Tree qualified as Tree+import GHC.Real (Ratio((:%)))++#if MIN_VERSION_base(4,17,0)+import GHC.IsList qualified as IsList+#else+import GHC.Exts qualified as IsList (fromList)+#endif++import Debug.RecoverRTTI++import Test.RecoverRTTI.ConcreteClassifier+import Test.RecoverRTTI.Prim+import Test.RecoverRTTI.QuickCheck.DepGen+import Test.RecoverRTTI.QuickCheck.Sized (SizedGen)+import Test.RecoverRTTI.QuickCheck.Sized qualified as SG+import Test.RecoverRTTI.UserDefined++{-------------------------------------------------------------------------------+ Primitive types+-------------------------------------------------------------------------------}++primDepGen :: PrimClassifier a -> DepGen Concrete a+primDepGen c =+ case (primSatisfiesArbitrary c, canShowPrim c, canComparePrim c) of+ (Dict, Dict, Dict) -> DepGen (CC_Prim c) $ unwrap <$> SG.arbitrary++{-------------------------------------------------------------------------------+ User-defined types+-------------------------------------------------------------------------------}++arbitraryUser :: SizedGen (Some (DepGen ConcreteUser))+arbitraryUser = SG.leafOrStep leaf compound+ where+ leaf :: Gen (Some (DepGen ConcreteUser))+ leaf = QC.oneof [+ -- SimpleType+ pure . Some $ arbitraryDepGen CC_Simple++ -- ContainsUnlifted+ , pure . Some $ arbitraryDepGen CC_Unlifted+ ]++ compound :: [SizedGen (Some (DepGen ConcreteUser))]+ compound = [+ -- NonRecursive+ go_U_K CC_NonRec (NR1 1234)+ (mapSome (GenK (fmap (NR2 True))) <$> arbitraryConcrete)++ -- Recursive+ , go_U_K CC_Rec RNil+ (mapSome (GenK (SG.genListLike recursiveFromList)) <$> arbitraryConcrete)+ ]++ go_U_K ::+ ( forall x. Show x => Show (f x)+ , forall x. Eq x => Eq (f x)+ )+ => (forall a. Concrete a -> ConcreteUser (f a))+ -> (forall a. f a)+ -> SizedGen (Some (GenK Concrete f))+ -> SizedGen (Some (DepGen ConcreteUser))+ go_U_K cf nothing just =+ SG.leafOrStep+ (pure $ Some $ DepGen (cf CC_Void) (pure nothing))+ [(\(Some a) -> Some (genJust cf a)) <$> just]++{-------------------------------------------------------------------------------+ Generate arbitiary classifiers+-------------------------------------------------------------------------------}++-- | Generated arbitrary classifier along with a generator for that value+--+-- NOTE: The " size " here refers to the size of the /classifier/. Along with+-- the classifier we construct a generator for values of the corresponding+-- type; that generator in turn has its own (independent) size parameter.+arbitraryConcrete :: SizedGen (Some (DepGen Concrete))+arbitraryConcrete = go+ where+ go :: SizedGen (Some (DepGen Concrete))+ go = SG.leafOrStep leaf compound++ -- Leaves of the tree (values with no recursion).+ --+ -- We will fail to generate a leaf when the size reaches 0; this ensures+ -- termination.+ leaf :: Gen (Some (DepGen Concrete))+ leaf = do+ Some c <- arbitraryPrimClassifier+ return $ Some $ primDepGen c++ -- Compound+ --+ -- We deduct one from the size for the outer-most constructor+ --+ -- For most types we generate arbitrary subtypes, but for some types we+ -- must pick subtypes satisfying a certain constraint (e.g., @Ord@ for+ -- @Set@); for such types we just pick a single example.+ compound :: [SizedGen (Some (DepGen Concrete))]+ compound = [+ (\(Some (DepGen c gen)) -> Some(DepGen (CC_Other c) gen)) <$> arbitraryUser++ , go_U_K CC_Maybe Nothing+ (mapSome (GenK (fmap Just)) <$> go)++ , go_KU_UK CC_Either+ (mapSome (GenKU (fmap Left)) <$> go)+ (mapSome (GenUK (fmap Right)) <$> go)++ -- @[Char]@ is classified as @String@+ , let notChar (Some (DepGen (CC_Prim C_Char) _)) = False+ notChar _otherwise = True in+ go_U_K CC_List []+ (mapSome (GenK (SG.genListLike id)) <$> (go `SG.suchThat` notChar))++ , go_K CC_Ratio $ pure . Some $ GenK {+ justGen = \g -> uncurry (:%) <$> SG.divvyPair g g+ , justElem = primDepGen C_Int+ }++ , go_U_K CC_Set Set.empty $ pure . Some $ GenK {+ justGen = SG.genListLike Set.fromList+ , justElem = primDepGen C_Int+ }++ , go_UU_KK CC_Map Map.empty+ ((\(Some genElem) -> Some $ GenKK {+ pairGen = SG.genMapLike Map.fromList+ , pairFst = primDepGen C_Int+ , pairSnd = genElem+ }) <$> go)++ , go_U_K CC_IntMap IntMap.empty+ ((\(Some genElem) -> Some $ GenK {+ justGen = SG.genMapLike IntMap.fromList SG.arbitrary+ , justElem = genElem+ }) <$> go)++ , go_U_K CC_Sequence Seq.empty+ (mapSome (GenK (SG.genListLike Seq.fromList)) <$> go)++ , go_K CC_Tree+ (mapSome (GenK (SG.genListLike mkSomeTree)) <$> go)++ , go_K CC_HashSet $ pure . Some $ GenK {+ justGen = SG.genListLike HashSet.fromList+ , justElem = primDepGen C_Int+ }++ -- @HashMap a ()@ is classified as a @HashSet@ instead+ , let notUnit (Some (DepGen (CC_Prim C_Unit) _)) = False+ notUnit _otherwise = True in+ go_UU_KK CC_HashMap HashMap.empty+ ((\(Some genElem) -> Some $ GenKK {+ pairGen = SG.genMapLike HashMap.fromList+ , pairFst = primDepGen C_Int+ , pairSnd = genElem+ }) <$> (go `SG.suchThat` notUnit))++ , let mkArray xs = HashMap.Array.fromList (length xs) xs in+ go_U_K CC_HM_Array (mkArray [])+ (mapSome (GenK (SG.genListLike mkArray)) <$> go)++ , go_U_K CC_Prim_Array (IsList.fromList [])+ (mapSome (GenK (SG.genListLike IsList.fromList)) <$> go)++ , go_U_K CC_Vector_Boxed Vector.Boxed.empty+ (mapSome (GenK (SG.genListLike Vector.Boxed.fromList)) <$> go)++ , goTuple+ ]++ go_K :: forall f.+ ( forall x. Show x => Show (f x)+ , forall x. Eq x => Eq (f x)+ )+ => (forall x. Concrete x -> Concrete (f x))+ -> SizedGen (Some (GenK Concrete f))+ -> SizedGen (Some (DepGen Concrete))+ go_K cf = fmap (\(Some a) -> Some (genJust cf a))++ go_U_K :: forall f.+ ( forall x. Show x => Show (f x)+ , forall x. Eq x => Eq (f x)+ )+ => (forall x. Concrete x -> Concrete (f x))+ -> f Void+ -> SizedGen (Some (GenK Concrete f))+ -> SizedGen (Some (DepGen Concrete))+ go_U_K cf nothing just =+ SG.leafOrStep+ (pure $ Some $ DepGen (cf CC_Void) (pure nothing))+ [(\(Some a) -> Some (genJust cf a)) <$> just]++ go_KU_UK :: forall f.+ ( forall x y. (Show x, Show y) => Show (f x y)+ , forall x y. (Eq x, Eq y) => Eq (f x y)+ )+ => (forall x y. Concrete x -> Concrete y -> Concrete (f x y))+ -> SizedGen (Some (GenKU Concrete f))+ -> SizedGen (Some (GenUK Concrete f))+ -> SizedGen (Some (DepGen Concrete))+ go_KU_UK cf left right =+ SG.oneofStepped [+ (\(Some a) -> Some (genLeft (\cc -> cf cc CC_Void) a)) <$> left+ , (\(Some b) -> Some (genRight (\cc -> cf CC_Void cc) b)) <$> right+ ]++ go_UU_KK :: forall (f :: Type -> Type -> Type).+ ( forall x y. (Show x, Show y) => Show (f x y)+ , forall x y. (Eq x, Eq y) => Eq (f x y)+ )+ => (forall x y. Concrete x -> Concrete y -> Concrete (f x y))+ -> (forall x y. f x y)+ -> SizedGen (Some (GenKK Concrete f))+ -> SizedGen (Some (DepGen Concrete))+ go_UU_KK cf nothing just =+ SG.leafOrStep+ (pure $ Some $ DepGen (cf CC_Void CC_Void) (pure nothing))+ [(\(Some ab@GenKK{}) -> Some (genPair (uncurry cf) ab)) <$> just]++ goTuple :: SizedGen (Some (DepGen Concrete))+ goTuple =+ (\(Some (SG.ValidTuple t)) -> Some (lift t)) <$> SG.genTuple go+ where+ lift :: (SListI xs, IsValidSize (Length xs))+ => NP (DepGen Concrete) xs+ -> DepGen Concrete (WrappedTuple xs)+ lift t = genNP (CC_Tuple . Concretes) $ GenNP {+ npGen = fmap tupleFromNP . hsequence+ , npElem = t+ }++ _checkAllCases :: Classifier_ o a -> ()+ _checkAllCases = \case+ -- Primitive and user-defined+ C_Prim{} -> ()+ C_Other{} -> ()++ -- Compound+ C_Either{} -> ()+ C_HashMap{} -> ()+ C_HashSet{} -> ()+ C_HM_Array{} -> ()+ C_IntMap{} -> ()+ C_List{} -> ()+ C_Map{} -> ()+ C_Maybe{} -> ()+ C_Prim_Array{} -> ()+ C_Ratio{} -> ()+ C_Sequence{} -> ()+ C_Set{} -> ()+ C_Tree{} -> ()+ C_Tuple{} -> ()+ C_Vector_Boxed{} -> ()++{-------------------------------------------------------------------------------+ Auxiliary tree functions+-------------------------------------------------------------------------------}++mkSomeTree :: [a] -> Tree a+mkSomeTree [] = error "mkSomeTree: empty"+mkSomeTree [x] = Tree.Node x []+mkSomeTree [x, y] = Tree.Node x [Tree.Node y []]+mkSomeTree (x : xs) =+ let (left, right) = split xs+ in Tree.Node x [mkSomeTree left, mkSomeTree right]++-- | Split list into halves+--+-- If the input has at least two elements, neither list will be empty+--+-- > split "abcde" == ("ace","bd")+split :: [a] -> ([a], [a])+split [] = ([], [])+split (x:xs) = first (x:) $ splot xs++-- | Auxiliary to 'split'+splot :: [a] -> ([a], [a])+splot [] = ([], [])+splot (x:xs) = second (x:) $ split xs
+ tests/Test/RecoverRTTI/ConcreteClassifier/Compatibility.hs view
@@ -0,0 +1,136 @@+module Test.RecoverRTTI.ConcreteClassifier.Compatibility (+ Compatible(..)+ , CompatibleNP(..)+ , compatibleClassifier+ ) where++import Data.SOP.NP+import Data.Type.Equality++import Debug.RecoverRTTI++import Test.RecoverRTTI.ConcreteClassifier+import Test.RecoverRTTI.Staged+import Test.RecoverRTTI.UserDefined++data Compatible a b where+ CompatibleSame :: Compatible a a+ CompatibleDeferred :: Compatible a Deferred+ CompatibleF1 :: Compatible a b -> Compatible (f a) (f b)+ CompatibleF2 :: Compatible a b+ -> Compatible a' b'+ -> Compatible (f a a') (f b b')+ CompatibleFn :: CompatibleNP as bs -> Compatible (f as) (f bs)++data CompatibleNP as bs where+ CompatibleNil :: CompatibleNP '[] '[]+ CompatibleNP :: Compatible a b+ -> CompatibleNP as bs+ -> CompatibleNP (a ': as) (b ': bs)++-- | Is the inferred classifier compatible with the generated classifier?+compatibleClassifier :: Concrete a -> UserClassifier b -> Maybe (Compatible a b)+compatibleClassifier = \concrete inferred ->+ case (concrete, inferred) of+ (CC_Prim c, C_Prim c') -> compatibleRefl <$> samePrim c c'+ (CC_Other c, C_Other c') -> compatibleUser c c'++ (CC_Maybe{} , C_Maybe ) -> Just deferredF1+ (CC_Ratio{} , C_Ratio ) -> Just deferredF1+ (CC_Set{} , C_Set ) -> Just deferredF1+ (CC_IntMap{} , C_IntMap ) -> Just deferredF1+ (CC_Tree{} , C_Tree ) -> Just deferredF1+ (CC_HashSet{} , C_HashSet ) -> Just deferredF1++ (CC_Sequence c , C_Sequence c') -> listElem c c'+ (CC_List c , C_List c') -> listElem c c'+ (CC_HM_Array c , C_HM_Array c') -> listElem c c'+ (CC_Vector_Boxed c , C_Vector_Boxed c') -> listElem c c'+ (CC_Prim_Array c , C_Prim_Array c') -> listElem c c'++ (CC_Either{} , C_Either ) -> Just deferredF2+ (CC_HashMap{} , C_HashMap ) -> Just deferredF2+ (CC_Map{} , C_Map ) -> Just deferredF2++ (CC_Tuple cs , C_Tuple cs' ) -> compatibleTuple cs cs'++ _otherwise -> Nothing+ where+ listElem ::+ Concrete a+ -> ClassifyListElem b+ -> Maybe (Compatible (f a) (f b))+ listElem = \concrete inferred ->+ case (concrete, inferred) of+ (_anything , C_List_Deferred) -> Just $ CompatibleF1 CompatibleDeferred+ (CC_Prim C_Char , C_List_Char ) -> Just $ CompatibleF1 CompatibleSame+ _otherwise -> Nothing++ _checkedAllCases :: Concrete a -> ()+ _checkedAllCases = \case+ CC_Either{} -> ()+ CC_HashMap{} -> ()+ CC_HashSet{} -> ()+ CC_HM_Array{} -> ()+ CC_IntMap{} -> ()+ CC_List{} -> ()+ CC_Map{} -> ()+ CC_Maybe{} -> ()+ CC_Other{} -> ()+ CC_Prim_Array{} -> ()+ CC_Prim{} -> ()+ CC_Ratio{} -> ()+ CC_Sequence{} -> ()+ CC_Set{} -> ()+ CC_Tree{} -> ()+ CC_Tuple{} -> ()+ CC_Vector_Boxed{} -> ()+ CC_Void{} -> ()++compatibleUser :: ConcreteUser a -> ClassifyUser b -> Maybe (Compatible a b)+compatibleUser = \concrete inferred ->+ case (concrete, inferred) of+ (CC_Simple , C_Simple ) -> Just CompatibleSame+ (CC_NonRec{} , C_NonRec ) -> Just deferredF1+ (CC_Rec{} , C_Rec ) -> Just deferredF1+ (CC_Unlifted , C_Unlifted) -> Just CompatibleSame+ _otherwise -> Nothing+ where+ _checkedAllCases :: ConcreteUser a -> ()+ _checkedAllCases = \case+ CC_Simple -> ()+ CC_NonRec{} -> ()+ CC_Rec{} -> ()+ CC_Unlifted -> ()++compatibleTuple ::+ Concretes as+ -> Classifiers_ ClassifyUser bs+ -> Maybe (Compatible (WrappedTuple as) (WrappedTuple bs))+compatibleTuple = \(Concretes concrete) (Classifiers_ inferred) ->+ CompatibleFn <$> go concrete inferred+ where+ go ::+ NP Concrete as+ -> NP UserClassifier bs+ -> Maybe (CompatibleNP as bs)+ go Nil Nil = Just CompatibleNil+ go Nil (_ :* _) = Nothing+ go (_ :* _) Nil = Nothing+ go (a :* as) (b :* bs) =+ pure CompatibleNP+ <*> compatibleClassifier a b+ <*> go as bs++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++compatibleRefl :: (a :~: b) -> Compatible a b+compatibleRefl Refl = CompatibleSame++deferredF1 :: Compatible (f a) (f Deferred)+deferredF1 = CompatibleF1 CompatibleDeferred++deferredF2 :: Compatible (f a b) (f Deferred Deferred)+deferredF2 = CompatibleF2 CompatibleDeferred CompatibleDeferred
+ tests/Test/RecoverRTTI/ConcreteClassifier/Constraint.hs view
@@ -0,0 +1,146 @@+module Test.RecoverRTTI.ConcreteClassifier.Constraint (+ UserSatisfies+ , userSatisfies+ , concreteSatisfies+ , canShowConcrete+ , canCompareConcrete+ ) where++import Data.HashMap.Internal.Array qualified as HashMap (Array)+import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet)+import Data.IntMap (IntMap)+import Data.Kind+import Data.Map (Map)+import Data.Primitive.Array qualified as Prim (Array)+import Data.Ratio+import Data.Sequence (Seq)+import Data.Set (Set)+import Data.SOP+import Data.SOP.Dict+import Data.Tree (Tree)+import Data.Vector qualified as Vector.Boxed+import Data.Void++import Debug.RecoverRTTI (PrimSatisfies, primSatisfies)+import Debug.RecoverRTTI (IsValidSize, Length, WrappedTuple)++import Test.RecoverRTTI.ConcreteClassifier+import Test.RecoverRTTI.Orphans ()+import Test.RecoverRTTI.UserDefined++{-------------------------------------------------------------------------------+ User-defined types+-------------------------------------------------------------------------------}++class (+ c SimpleType+ , forall a. c a => c (NonRecursive a)+ , forall a. c a => c (Recursive a)+ , c ContainsUnlifted+ ) => UserSatisfies c++instance (+ c SimpleType+ , forall a. c a => c (NonRecursive a)+ , forall a. c a => c (Recursive a)+ , c ContainsUnlifted+ ) => UserSatisfies c++userSatisfies :: forall c a. ConcreteSatisfies c => ConcreteUser a -> Dict c a+userSatisfies = go+ where+ go :: forall x. ConcreteUser x -> Dict c x+ go CC_Simple = Dict+ go (CC_NonRec c) = case auxConcrete c of Dict -> Dict+ go (CC_Rec c) = case auxConcrete c of Dict -> Dict+ go CC_Unlifted = Dict++ auxConcrete :: forall x. Concrete x -> Dict c x+ auxConcrete = concreteSatisfies++{-------------------------------------------------------------------------------+ Compound+-------------------------------------------------------------------------------}++class (+ PrimSatisfies c+ , UserSatisfies c+ , c Void+ -- Compound+ , forall a. (c a) => c (Maybe a)+ , forall a b. (c a, c b) => c (Either a b)+ , forall a. (c a) => c [a]+ , forall a. (c a) => c (Ratio a)+ , forall a. (c a) => c (Set a)+ , forall a b. (c a, c b) => c (Map a b)+ , forall a. (c a) => c (IntMap a)+ , forall a. (c a) => c (Seq a)+ , forall a. (c a) => c (Tree a)+ , forall a. (c a) => c (HashSet a)+ , forall a b. (c a, c b) => c (HashMap a b)+ , forall a. (c a) => c (HashMap.Array a)+ , forall a. (c a) => c (Prim.Array a)+ , forall a. (c a) => c (Vector.Boxed.Vector a)+ , forall xs. (All c xs, IsValidSize (Length xs)) => c (WrappedTuple xs)+ ) => ConcreteSatisfies (c :: Type -> Constraint)++instance (+ PrimSatisfies c+ , UserSatisfies c+ , c Void+ -- Compound+ , forall a. (c a) => c (Maybe a)+ , forall a b. (c a, c b) => c (Either a b)+ , forall a. (c a) => c [a]+ , forall a. (c a) => c (Ratio a)+ , forall a. (c a) => c (Set a)+ , forall a b. (c a, c b) => c (Map a b)+ , forall a. (c a) => c (IntMap a)+ , forall a. (c a) => c (Seq a)+ , forall a. (c a) => c (Tree a)+ , forall a. (c a) => c (HashSet a)+ , forall a b. (c a, c b) => c (HashMap a b)+ , forall a. (c a) => c (HashMap.Array a)+ , forall a. (c a) => c (Prim.Array a)+ , forall a. (c a) => c (Vector.Boxed.Vector a)+ , forall xs. (All c xs, IsValidSize (Length xs)) => c (WrappedTuple xs)+ ) => ConcreteSatisfies (c :: Type -> Constraint)++concreteSatisfies :: forall c a. ConcreteSatisfies c => Concrete a -> Dict c a+concreteSatisfies = go+ where+ go :: forall x. Concrete x -> Dict c x+ go (CC_Prim c) = primSatisfies c+ go (CC_Other c) = userSatisfies c+ go CC_Void = Dict++ -- Compound types with unclassified elements+ go (CC_HashSet c1 ) = case go c1 of Dict -> Dict+ go (CC_IntMap c1 ) = case go c1 of Dict -> Dict+ go (CC_Maybe c1 ) = case go c1 of Dict -> Dict+ go (CC_Ratio c1 ) = case go c1 of Dict -> Dict+ go (CC_Set c1 ) = case go c1 of Dict -> Dict+ go (CC_Tree c1 ) = case go c1 of Dict -> Dict++ go (CC_HM_Array c1 ) = case go c1 of Dict -> Dict+ go (CC_List c1 ) = case go c1 of Dict -> Dict+ go (CC_Prim_Array c1 ) = case go c1 of Dict -> Dict+ go (CC_Sequence c1 ) = case go c1 of Dict -> Dict+ go (CC_Vector_Boxed c1 ) = case go c1 of Dict -> Dict++ go (CC_Either c1 c2) = case (go c1, go c2) of (Dict, Dict) -> Dict+ go (CC_HashMap c1 c2) = case (go c1, go c2) of (Dict, Dict) -> Dict+ go (CC_Map c1 c2) = case (go c1, go c2) of (Dict, Dict) -> Dict++ -- Compound types with classified elements+ go (CC_Tuple cs) = goNP cs Dict++ goNP :: SListI as => Concretes as -> (All c as => r) -> r+ goNP (Concretes cs) k = case all_NP (hmap go cs) of Dict -> k++canShowConcrete :: Concrete a -> Dict Show a+canShowConcrete = concreteSatisfies++canCompareConcrete :: Concrete a -> Dict Eq a+canCompareConcrete = concreteSatisfies
+ tests/Test/RecoverRTTI/ConcreteClassifier/Size.hs view
@@ -0,0 +1,53 @@+module Test.RecoverRTTI.ConcreteClassifier.Size (+ sizeConcrete+ , sizeUser+ ) where++import Data.SOP++import Test.RecoverRTTI.ConcreteClassifier++{-------------------------------------------------------------------------------+ Size of the classifier++ Mostly used for sanity checking the generator+-------------------------------------------------------------------------------}++sizeConcrete :: Concrete a -> Int+sizeConcrete = go+ where+ go :: Concrete a -> Int+ go (CC_Prim _ ) = 1+ go (CC_Other c ) = sizeUser c+ go CC_Void = 1++ go (CC_HashSet c1 ) = 1 + go c1+ go (CC_IntMap c1 ) = 1 + go c1+ go (CC_Maybe c1 ) = 1 + go c1+ go (CC_Ratio c1 ) = 1 + go c1+ go (CC_Set c1 ) = 1 + go c1+ go (CC_Tree c1 ) = 1 + go c1++ go (CC_HM_Array c1 ) = 1 + go c1+ go (CC_List c1 ) = 1 + go c1+ go (CC_Prim_Array c1 ) = 1 + go c1+ go (CC_Sequence c1 ) = 1 + go c1+ go (CC_Vector_Boxed c1 ) = 1 + go c1++ go (CC_Either c1 c2) = 1 + go c1 + go c2+ go (CC_HashMap c1 c2) = 1 + go c1 + go c2+ go (CC_Map c1 c2) = 1 + go c1 + go c2++ go (CC_Tuple cs ) = 1 + goNP cs++ goNP :: SListI as => Concretes as -> Int+ goNP (Concretes cs) = sum . hcollapse $ hmap (K . go) cs++sizeUser :: ConcreteUser a -> Int+sizeUser = go+ where+ go :: ConcreteUser a -> Int+ go CC_Simple = 1+ go (CC_NonRec c) = 1 + sizeConcrete c+ go (CC_Rec c) = 1 + sizeConcrete c+ go CC_Unlifted = 1
+ tests/Test/RecoverRTTI/ConcreteClassifier/Value.hs view
@@ -0,0 +1,35 @@+module Test.RecoverRTTI.ConcreteClassifier.Value (+ Value(..)+ ) where++import Test.QuickCheck (Arbitrary(..))++import Debug.RecoverRTTI++import Test.RecoverRTTI.ConcreteClassifier+import Test.RecoverRTTI.ConcreteClassifier.Arbitrary+import Test.RecoverRTTI.QuickCheck.DepGen+import Test.RecoverRTTI.QuickCheck.Sized qualified as SG++{-------------------------------------------------------------------------------+ Definition+-------------------------------------------------------------------------------}++-- | Like 'Classified', but using 'Concrete'+--+-- For convenience, we also include some constraints here, even though they+-- are in fact derivable from the classifier+data Value a where+ Value :: (Show a, Eq a) => Concrete a -> a -> Value a++deriving instance Show (Value a)+deriving instance Show (Some Value)++instance Arbitrary (Some Value) where+ arbitrary = do+ -- We don't want to generate large classifiers+ Some (DepGen cc gen) <- SG.run 10 arbitraryConcrete++ -- For the values however we want to be able to generate larger trees+ Some . Value cc <$> SG.run 1000 gen+
+ tests/Test/RecoverRTTI/Orphans.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Equality orphan instances+module Test.RecoverRTTI.Orphans () where++import Data.Function (on)+import Data.HashMap.Internal.Array qualified as HashMap (Array)+import Data.HashMap.Internal.Array qualified as HashMap.Array++import Debug.RecoverRTTI++{-------------------------------------------------------------------------------+ Reasonable instances+-------------------------------------------------------------------------------}++instance Eq a => Eq (HashMap.Array a) where+ (==) = (==) `on` HashMap.Array.toList++{-------------------------------------------------------------------------------+ Degenerate instances++ It is (obviously!) important that these are available in the test suite only.+-------------------------------------------------------------------------------}++instance Eq SomeFun where+ _ == _ = True++instance Eq SomePrimArrayM where+ _ == _ = True++instance Eq SomeStorableVector where+ _ == _ = True++instance Eq SomeStorableVectorM where+ _ == _ = True++instance Eq SomePrimitiveVector where+ _ == _ = True++instance Eq SomePrimitiveVectorM where+ _ == _ = True++instance Eq SomeMutableByteArray where+ _ == _ = True
tests/Test/RecoverRTTI/Prim.hs view
@@ -42,8 +42,8 @@ import Test.QuickCheck (Arbitrary(..), Gen) import Test.QuickCheck qualified as QC -import Test.RecoverRTTI.Classifier.Equality () import Test.RecoverRTTI.Globals+import Test.RecoverRTTI.Orphans () {------------------------------------------------------------------------------- Equality@@ -83,7 +83,6 @@ -- String types - , Some C_String , Some C_BS_Strict , Some C_BS_Lazy , Some C_Text_Strict@@ -143,7 +142,6 @@ -- String types - C_String -> () C_BS_Strict -> () C_BS_Lazy -> () C_Text_Strict -> ()@@ -319,5 +317,3 @@ instance Arbitrary (Wrap SomeMutableByteArray) where arbitrary = return $ Wrap exampleMutableByteArray--
tests/Test/RecoverRTTI/QuickCheck/DepGen.hs view
@@ -5,7 +5,6 @@ , depGen -- * Creation , arbitraryDepGen- , primDepGen -- * Bundle a dependent generator with a lifting function , GenK(..) , GenKU(..)@@ -22,13 +21,8 @@ import Data.Kind import Data.SOP import Data.SOP.Dict-import Data.Void--import Debug.RecoverRTTI- import Test.QuickCheck -import Test.RecoverRTTI.Prim import Test.RecoverRTTI.QuickCheck.Sized (SizedGen) import Test.RecoverRTTI.QuickCheck.Sized qualified as SG @@ -53,13 +47,6 @@ arbitraryDepGen :: (Arbitrary a, Show a, Eq a) => c a -> DepGen c a arbitraryDepGen cc = DepGen cc $ SG.arbitrary -primDepGen :: PrimClassifier a -> DepGen (Classifier_ o) a-primDepGen C_String = DepGen (C_Prim C_String) $ SG.lift $- arbitrary `suchThat` (not . null) -- empty string classified as @[Void]@-primDepGen c =- case (primSatisfiesArbitrary c, canShowPrim c, canComparePrim c) of- (Dict, Dict, Dict) -> DepGen (C_Prim c) $ unwrap <$> SG.arbitrary- {------------------------------------------------------------------------------- Bundle a dependent generator with a lifting function @@ -72,12 +59,12 @@ } data GenKU c (f :: Type -> Type -> Type) a = GenKU {- leftGen :: SizedGen a -> SizedGen (f a Void)+ leftGen :: forall b. SizedGen a -> SizedGen (f a b) , leftElem :: DepGen c a } data GenUK c (f :: Type -> Type -> Type) b = GenUK {- rightGen :: SizedGen b -> SizedGen (f Void b)+ rightGen :: forall a. SizedGen b -> SizedGen (f a b) , rightElem :: DepGen c b } @@ -105,16 +92,18 @@ genLeft :: ( forall x y. (Show x, Show y) => Show (f x y) , forall x y. (Eq x, Eq y) => Eq (f x y)+ , Show b, Eq b )- => (c a -> c' (f a Void)) -> GenKU c f a -> DepGen c' (f a Void)+ => (c a -> c' (f a b)) -> GenKU c f a -> DepGen c' (f a b) genLeft cf (GenKU gen (DepGen cx gx)) = DepGen (cf cx) (gen gx) genRight :: ( forall x y. (Show x, Show y) => Show (f x y) , forall x y. (Eq x, Eq y) => Eq (f x y)+ , Show a, Eq a )- => (c b -> c' (f Void b)) -> GenUK c f b -> DepGen c' (f Void b)+ => (c b -> c' (f a b)) -> GenUK c f b -> DepGen c' (f a b) genRight cf (GenUK gen (DepGen cy gy)) = DepGen (cf cy) (gen gy)
tests/Test/RecoverRTTI/Sanity.hs view
@@ -1,18 +1,20 @@ module Test.RecoverRTTI.Sanity (tests) where +import Data.HashMap.Lazy (HashMap)+import Data.HashMap.Lazy qualified as HashMap import Data.SOP.BasicFunctors import GHC.Exts (Any)-import Unsafe.Coerce (unsafeCoerce)--import Debug.RecoverRTTI-+import Test.QuickCheck (Property)+import Test.QuickCheck qualified as QC import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty)-import Test.QuickCheck (Property)-import Test.QuickCheck qualified as QC+import Unsafe.Coerce (unsafeCoerce) -import Test.RecoverRTTI.ConcreteClassifier+import Debug.RecoverRTTI++import Test.RecoverRTTI.ConcreteClassifier.Arbitrary+import Test.RecoverRTTI.ConcreteClassifier.Size import Test.RecoverRTTI.QuickCheck.DepGen import Test.RecoverRTTI.QuickCheck.Sized qualified as SG @@ -20,7 +22,13 @@ tests = testGroup "Test.RecoverRTTI.Sanity" [ testProperty "typeSize" prop_typeSize , testCase "derivingVia" test_derivingVia- , testCase "BoxAnythingToString" test_BoxAnythingToString++ , testGroup "Any" [+ testCase "listSimple" test_Any_listSimple+ , testCase "listChar" test_Any_listChar+ , testCase "hashMapSimple" test_Any_hashMapSimple+ , testCase "hashMapUnit" test_Any_hashMapUnit+ ] ] prop_typeSize :: Property@@ -44,24 +52,52 @@ test_derivingVia = assertEqual "" "T2 (T1 1 True)" $ show (T2 (T1 1 True)) {-------------------------------------------------------------------------------- BoxAnythingToString+ Unsafe heterogenous datastructures -------------------------------------------------------------------------------} -data T3 f = T3 [f Any]--deriving instance Show a => Show (T3 (K a))+-- | Simple hererogeneous lists (without 'Char')+test_Any_listSimple :: Assertion+test_Any_listSimple =+ assertEqual "" "[1,False]" $ anythingToString testValue+ where+ testValue :: [I Any]+ testValue = [+ unsafeCoerce (1 :: Int)+ , unsafeCoerce False+ ] -t3BadExample :: T3 I-t3BadExample = T3 [unsafeCoerce (1 :: Int), unsafeCoerce False]+-- | Hererogeneous lists that start with a 'Char'+--+-- This is particularly unpleasant, as these might be mistaken for 'String's.+test_Any_listChar :: Assertion+test_Any_listChar =+ assertEqual "" "['a',1,False]" $ anythingToString testValue+ where+ testValue :: [I Any]+ testValue = [+ unsafeCoerce 'a'+ , unsafeCoerce (1 :: Int)+ , unsafeCoerce False+ ] -t3GoodExample :: T3 (K BoxAnything)-t3GoodExample = T3 [K $ BoxAnything (1 :: Int), K $ BoxAnything False]+test_Any_hashMapSimple :: Assertion+test_Any_hashMapSimple =+ assertEqual "" "fromList [(1,'a'),(2,False)]" $ anythingToString testValue+ where+ testValue :: HashMap Int Any+ testValue = HashMap.fromList [+ (1, unsafeCoerce 'a')+ , (2, unsafeCoerce False)+ ] -test_BoxAnythingToString :: Assertion-test_BoxAnythingToString = do- assertBool "bad" $- anythingToString t3BadExample /= "T3 [1,False]"- assertEqual "good - show" "T3 [K 1,K False]" $- show t3GoodExample- assertEqual "good - anythingToString" "T3 [BoxAnything 1,BoxAnything False]" $- anythingToString t3GoodExample+-- | HashMap with () as the first value will be mistaken for a HashSet+test_Any_hashMapUnit :: Assertion+test_Any_hashMapUnit =+ assertEqual "" "fromList [0,1,2]" $ anythingToString testValue+ where+ testValue :: HashMap Int Any+ testValue = HashMap.fromList [+ (0, unsafeCoerce ())+ , (1, unsafeCoerce 'a')+ , (2, unsafeCoerce False)+ ]
tests/Test/RecoverRTTI/Show.hs view
@@ -1,21 +1,33 @@ -- | Verify that 'anythingToString' produces same result as 'show' module Test.RecoverRTTI.Show (tests) where -import Test.Tasty-import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck (Property, (===)) import Test.QuickCheck qualified as QC+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (testProperty) import Debug.RecoverRTTI -import Test.RecoverRTTI.ConcreteClassifier+import Test.RecoverRTTI.ConcreteClassifier.Value +{-------------------------------------------------------------------------------+ List of all tests+-------------------------------------------------------------------------------}+ tests :: TestTree tests = testGroup "Test.RecoverRTTI.Show" [ testProperty "showGenerated" prop_showGenerated , testProperty "anythingToString" prop_anythingToString+ , testGroup "Regression" [+ testCase "issue51" test_issue51+ ] ] +{-------------------------------------------------------------------------------+ Property tests+-------------------------------------------------------------------------------}+ -- | Check that the generated value is showable -- -- This is a sanity check on the generator.@@ -30,3 +42,16 @@ QC.counterexample ("inferred: " ++ show (classify x)) $ QC.within 2_000_000 $ show x === anythingToString x++{-------------------------------------------------------------------------------+ Regression tests+-------------------------------------------------------------------------------}++test_issue51 :: Assertion+test_issue51 =+ assertEqual "" (show value) (anythingToString value)+ where+ value :: [Maybe Bool]+ value = [Nothing, Just True]++
tests/Test/RecoverRTTI/Staged.hs view
@@ -17,25 +17,27 @@ -- In this module we do staged inference for the user-defined types used in the -- test suite. The primary purpose of this is to provide evidence that -- 'classify' gives us enough information to do so.-module Test.RecoverRTTI.Staged (classifyConcrete, reclassify) where+module Test.RecoverRTTI.Staged (+ UserClassifier+ , classifyConcrete+ , reclassify+ ) where import Control.Monad.Except import Data.SOP hiding (NS(..))-import Data.Void-import Unsafe.Coerce (unsafeCoerce) import Debug.RecoverRTTI-import Debug.RecoverRTTI.Classify -import Test.RecoverRTTI.ConcreteClassifier import Test.RecoverRTTI.UserDefined {------------------------------------------------------------------------------- Reclassified values -------------------------------------------------------------------------------} +type UserClassifier = Classifier_ ClassifyUser+ -- | Classify, then reclassify-classifyConcrete :: a -> Except String (Reclassified ConcreteClassifier a)+classifyConcrete :: a -> Except String (Reclassified UserClassifier a) classifyConcrete x = case classify x of Left closure ->@@ -46,15 +48,15 @@ -- | Reclassify values -- -- See detailed description in 'Reclassified'.-reclassify :: Classifier a -> Except String (Reclassified ConcreteClassifier a)+reclassify :: Classifier a -> Except String (Reclassified UserClassifier a) reclassify = fmap distribReclassified . reclassify_ go where go :: IsUserDefined a -> Except String (Reclassified ClassifyUser a) go (IsUserDefined x) = firstMatch ("Unknown constructor: " ++ constr) [ goSimple C_Simple constr- , goTraversable C_NonRec (constr, x)- , goTraversable C_Rec (constr, x)+ , goTraversable C_NonRec constr+ , goTraversable C_Rec constr , goSimple C_Unlifted constr ] where@@ -72,26 +74,14 @@ else return . Just $ Reclassified c FromUsr goTraversable ::- forall f. (Traversable f, ConstrsOf f)- => (forall a. Elems ClassifyUser '[a] -> ClassifyUser (f a))- -> (String, UserDefined)+ forall f. ConstrsOf f+ => ClassifyUser (f Deferred)+ -> String -> Except String (Maybe (Reclassified ClassifyUser UserDefined))- goTraversable cc = \(constr, x) ->- if constr `notElem` constrsOf (Proxy @f) then- return Nothing- else- case checkEmptyTraversable (coerceToF x) of- Right _ -> return . Just $ Reclassified (cc ElemU) FromUsr- Left x' -> Just . aux <$> classifyConcrete x'- where- coerceToF :: forall a. UserDefined -> f a- coerceToF = unsafeCoerce-- aux ::- Reclassified ConcreteClassifier a- -> Reclassified ClassifyUser UserDefined- aux (Reclassified c pf) =- Reclassified (cc (ElemK c)) (F1 pf `Compose` FromUsr)+ goTraversable c constr =+ if constr `notElem` constrsOf (Proxy @f)+ then return Nothing+ else return . Just $ Reclassified c FromUsr {------------------------------------------------------------------------------- Auxiliary@@ -103,10 +93,3 @@ go :: [Except e (Maybe a)] -> Except e a go [] = throwError err go (x:xs) = x >>= maybe (go xs) return---- | Check if a traversable data structure is empty------ Returns evidence: an element of the data-structure if it's non-empty,--- or evidence that it is empty otherwise.-checkEmptyTraversable :: Traversable t => t a -> Either a (t Void)-checkEmptyTraversable = traverse Left
tests/Test/RecoverRTTI/UserDefined.hs view
@@ -10,16 +10,19 @@ , ContainsUnlifted -- opaque , exampleContainsUnlifted , ConstrsOf(..)+ , ClassifyUser(..) ) where +import Data.Kind import Data.Proxy import GHC.Exts (RealWorld, MutableArray#, newArray#) import GHC.Generics import GHC.IO (IO(..)) import System.IO.Unsafe (unsafePerformIO)- import Test.QuickCheck +import Debug.RecoverRTTI+ {------------------------------------------------------------------------------- User-defined datatypes -------------------------------------------------------------------------------}@@ -88,3 +91,15 @@ instance Arbitrary ContainsUnlifted where arbitrary = return exampleContainsUnlifted++{-------------------------------------------------------------------------------+ Classifier+-------------------------------------------------------------------------------}++data ClassifyUser (a :: Type) where+ C_Simple :: ClassifyUser SimpleType+ C_NonRec :: ClassifyUser (NonRecursive Deferred)+ C_Rec :: ClassifyUser (Recursive Deferred)+ C_Unlifted :: ClassifyUser ContainsUnlifted++deriving stock instance Show (ClassifyUser a)