diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/recover-rtti.cabal b/recover-rtti.cabal --- a/recover-rtti.cabal +++ b/recover-rtti.cabal @@ -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 diff --git a/src/Debug/RecoverRTTI.hs b/src/Debug/RecoverRTTI.hs --- a/src/Debug/RecoverRTTI.hs +++ b/src/Debug/RecoverRTTI.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/CheckSame.hs b/src/Debug/RecoverRTTI/CheckSame.hs --- a/src/Debug/RecoverRTTI/CheckSame.hs +++ b/src/Debug/RecoverRTTI/CheckSame.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/Classifier.hs b/src/Debug/RecoverRTTI/Classifier.hs --- a/src/Debug/RecoverRTTI/Classifier.hs +++ b/src/Debug/RecoverRTTI/Classifier.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/Classify.hs b/src/Debug/RecoverRTTI/Classify.hs --- a/src/Debug/RecoverRTTI/Classify.hs +++ b/src/Debug/RecoverRTTI/Classify.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/Constraint.hs b/src/Debug/RecoverRTTI/Constraint.hs --- a/src/Debug/RecoverRTTI/Constraint.hs +++ b/src/Debug/RecoverRTTI/Constraint.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/Debugging.hs b/src/Debug/RecoverRTTI/Debugging.hs --- a/src/Debug/RecoverRTTI/Debugging.hs +++ b/src/Debug/RecoverRTTI/Debugging.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/Reclassify.hs b/src/Debug/RecoverRTTI/Reclassify.hs --- a/src/Debug/RecoverRTTI/Reclassify.hs +++ b/src/Debug/RecoverRTTI/Reclassify.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/Wrappers.hs b/src/Debug/RecoverRTTI/Wrappers.hs --- a/src/Debug/RecoverRTTI/Wrappers.hs +++ b/src/Debug/RecoverRTTI/Wrappers.hs @@ -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 {------------------------------------------------------------------------------- diff --git a/tests/Test/RecoverRTTI/Classifier/Arbitrary.hs b/tests/Test/RecoverRTTI/Classifier/Arbitrary.hs deleted file mode 100644 --- a/tests/Test/RecoverRTTI/Classifier/Arbitrary.hs +++ /dev/null @@ -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 diff --git a/tests/Test/RecoverRTTI/Classifier/Equality.hs b/tests/Test/RecoverRTTI/Classifier/Equality.hs deleted file mode 100644 --- a/tests/Test/RecoverRTTI/Classifier/Equality.hs +++ /dev/null @@ -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 diff --git a/tests/Test/RecoverRTTI/Classifier/Size.hs b/tests/Test/RecoverRTTI/Classifier/Size.hs deleted file mode 100644 --- a/tests/Test/RecoverRTTI/Classifier/Size.hs +++ /dev/null @@ -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 diff --git a/tests/Test/RecoverRTTI/Classify.hs b/tests/Test/RecoverRTTI/Classify.hs --- a/tests/Test/RecoverRTTI/Classify.hs +++ b/tests/Test/RecoverRTTI/Classify.hs @@ -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 + diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier.hs b/tests/Test/RecoverRTTI/ConcreteClassifier.hs --- a/tests/Test/RecoverRTTI/ConcreteClassifier.hs +++ b/tests/Test/RecoverRTTI/ConcreteClassifier.hs @@ -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 diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier/Arbitrary.hs b/tests/Test/RecoverRTTI/ConcreteClassifier/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/ConcreteClassifier/Arbitrary.hs @@ -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 diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier/Compatibility.hs b/tests/Test/RecoverRTTI/ConcreteClassifier/Compatibility.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/ConcreteClassifier/Compatibility.hs @@ -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 diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier/Constraint.hs b/tests/Test/RecoverRTTI/ConcreteClassifier/Constraint.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/ConcreteClassifier/Constraint.hs @@ -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 diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier/Size.hs b/tests/Test/RecoverRTTI/ConcreteClassifier/Size.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/ConcreteClassifier/Size.hs @@ -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 diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier/Value.hs b/tests/Test/RecoverRTTI/ConcreteClassifier/Value.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/ConcreteClassifier/Value.hs @@ -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 + diff --git a/tests/Test/RecoverRTTI/Orphans.hs b/tests/Test/RecoverRTTI/Orphans.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Orphans.hs @@ -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 diff --git a/tests/Test/RecoverRTTI/Prim.hs b/tests/Test/RecoverRTTI/Prim.hs --- a/tests/Test/RecoverRTTI/Prim.hs +++ b/tests/Test/RecoverRTTI/Prim.hs @@ -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 - - diff --git a/tests/Test/RecoverRTTI/QuickCheck/DepGen.hs b/tests/Test/RecoverRTTI/QuickCheck/DepGen.hs --- a/tests/Test/RecoverRTTI/QuickCheck/DepGen.hs +++ b/tests/Test/RecoverRTTI/QuickCheck/DepGen.hs @@ -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) diff --git a/tests/Test/RecoverRTTI/Sanity.hs b/tests/Test/RecoverRTTI/Sanity.hs --- a/tests/Test/RecoverRTTI/Sanity.hs +++ b/tests/Test/RecoverRTTI/Sanity.hs @@ -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) + ] diff --git a/tests/Test/RecoverRTTI/Show.hs b/tests/Test/RecoverRTTI/Show.hs --- a/tests/Test/RecoverRTTI/Show.hs +++ b/tests/Test/RecoverRTTI/Show.hs @@ -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] + + diff --git a/tests/Test/RecoverRTTI/Staged.hs b/tests/Test/RecoverRTTI/Staged.hs --- a/tests/Test/RecoverRTTI/Staged.hs +++ b/tests/Test/RecoverRTTI/Staged.hs @@ -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 diff --git a/tests/Test/RecoverRTTI/UserDefined.hs b/tests/Test/RecoverRTTI/UserDefined.hs --- a/tests/Test/RecoverRTTI/UserDefined.hs +++ b/tests/Test/RecoverRTTI/UserDefined.hs @@ -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)