diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for recover-rtti +## 0.4.1 -- 2022-03-17 + +* Support for ghc 9.2, bytestring 0.11, aeson 0.2 +* Added `traceAnything` and `traceAnythingId` (#13) +* Added deriving-via support (`AnythingToString`, `BoxAnything`) (#3) + ## 0.4 -- 2021-06-30 * Correctly set some required lower bounds. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ library is ```haskell -classify :: a -> Classifier a +classify :: a -> Either Closure (Classifier a) ``` which recovers type information about values about which we know nothing (in 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.4.0.0 +version: 0.4.1.0 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 @@ -20,8 +20,12 @@ README.md CHANGELOG.md -Tested-With: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 +Tested-With: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2 +source-repository head + type: git + location: https://github.com/well-typed/recover-rtti + library exposed-modules: Debug.RecoverRTTI Debug.RecoverRTTI.Classify @@ -30,6 +34,7 @@ other-modules: Debug.RecoverRTTI.CheckSame Debug.RecoverRTTI.Classifier Debug.RecoverRTTI.Constraint + Debug.RecoverRTTI.Debugging Debug.RecoverRTTI.FlatClosure Debug.RecoverRTTI.Modules Debug.RecoverRTTI.Nat @@ -40,21 +45,21 @@ Debug.RecoverRTTI.Util Debug.RecoverRTTI.Wrappers - build-depends: base >= 4.13 && < 4.16 - , aeson >= 1.4 && < 1.6 - , bytestring >= 0.10 && < 0.11 + build-depends: base >= 4.13 && < 4.17 + , aeson >= 1.4 && < 2.1 + , bytestring >= 0.10 && < 0.12 , containers >= 0.6 && < 0.7 - , ghc-heap >= 8.8 && < 9.1 + , ghc-heap >= 8.8 && < 9.3 , mtl >= 2.2 && < 2.3 , sop-core >= 0.5 && < 0.6 , stm >= 2.5 && < 2.6 - , text >= 1.2 && < 1.3 + , text >= 1.2 && < 2.1 -- 0.2.12 introduces Data.HashMap.Internal.Array , unordered-containers >= 0.2.12 && < 0.3 - -- THe oldest ghc we support is 8.8. - -- The dependencies below are the oldest versions of - -- these packages that compile with this ghc version. + -- The oldest ghc we support is 8.8. + -- The dependencies below are the oldest versions of + -- these packages that compile with this ghc version. , vector >= 0.12.1.2 && < 0.13 , primitive >= 0.7 && < 0.8 @@ -95,9 +100,9 @@ , sop-core , stm , tasty + , tasty-hunit , tasty-quickcheck , text , unordered-containers , vector ghc-options: -Wall - -Wno-orphans diff --git a/src/Debug/RecoverRTTI.hs b/src/Debug/RecoverRTTI.hs --- a/src/Debug/RecoverRTTI.hs +++ b/src/Debug/RecoverRTTI.hs @@ -2,6 +2,13 @@ module Debug.RecoverRTTI ( -- * Take advance of the recovered type information anythingToString + -- * Debugging support + -- ** Tracing + , traceAnything + , traceAnythingId + -- ** Deriving-via + , AnythingToString(..) + , BoxAnything(..) -- * Recover type information , classify , Classifier @@ -81,6 +88,7 @@ import Debug.RecoverRTTI.Classifier import Debug.RecoverRTTI.Classify import Debug.RecoverRTTI.Constraint +import Debug.RecoverRTTI.Debugging import Debug.RecoverRTTI.Nat import Debug.RecoverRTTI.Reclassify import Debug.RecoverRTTI.Tuple 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 @@ -122,7 +122,10 @@ -- -- bytestring + -- + -- bytestring changed from PS to BS in version 0.11 (inKnownModule DataByteStringInternal -> Just "PS") -> return $ mustBe $ C_Prim C_BS_Strict + (inKnownModule DataByteStringInternal -> Just "BS") -> return $ mustBe $ C_Prim C_BS_Strict (inKnownModule DataByteStringLazyInternal -> Just "Empty") -> return $ mustBe $ C_Prim C_BS_Lazy (inKnownModule DataByteStringLazyInternal -> Just "Chunk") -> return $ mustBe $ C_Prim C_BS_Lazy (inKnownModule DataByteStringShortInternal -> Just "SBS") -> return $ mustBe $ C_Prim C_BS_Short diff --git a/src/Debug/RecoverRTTI/Debugging.hs b/src/Debug/RecoverRTTI/Debugging.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Debugging.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- | Debugging support +module Debug.RecoverRTTI.Debugging ( + -- * Tracing + traceAnything + , traceAnythingId + -- * Deriving-via support + , AnythingToString(..) + , BoxAnything(..) + ) where + +import Debug.Trace + +import Debug.RecoverRTTI.Classify + +{------------------------------------------------------------------------------- + Tracing +-------------------------------------------------------------------------------} + +-- | Like 'traceShow', but using 'anythingToString' +traceAnything :: a -> b -> b +traceAnything a = trace (anythingToString a) + +-- | Like 'traceShowId', but using 'anythingToString' +traceAnythingId :: a -> a +traceAnythingId a = trace (anythingToString a) a + +{------------------------------------------------------------------------------- + Deriving-via support +-------------------------------------------------------------------------------} + +-- | Deriving-via support for 'anythingToString' +-- +-- If for debugging purposes you want to temporarily add a 'Show' instance to +-- an arbitrary datatype in terms of 'anythingToString', you can do so using +-- +-- > data T = MkT ... +-- > deriving Show via AnythingToString T +-- +-- This is equivalent to saying +-- +-- > instance Show T where +-- > show = anythingToString +newtype AnythingToString a = AnythingToString a + +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/tests/Test/RecoverRTTI/Classifier/Equality.hs b/tests/Test/RecoverRTTI/Classifier/Equality.hs --- a/tests/Test/RecoverRTTI/Classifier/Equality.hs +++ b/tests/Test/RecoverRTTI/Classifier/Equality.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + -- | Equality orphan instances module Test.RecoverRTTI.Classifier.Equality () where @@ -6,7 +8,35 @@ import qualified Data.HashMap.Internal.Array as HashMap (Array) import qualified Data.HashMap.Internal.Array as HashMap.Array -import Test.RecoverRTTI.Prim () +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 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 @@ -1,17 +1,27 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} module Test.RecoverRTTI.Prim ( -- * Equality canComparePrim -- * Arbitrary + , Wrap(..) , primSatisfiesArbitrary , arbitraryPrimClassifier ) where -import Control.Monad +import Control.Monad (replicateM) +import Data.Int +import Data.IntSet (IntSet) +import Data.SOP (Compose) import Data.SOP.Dict +import Data.String (fromString) +import Data.Word import Unsafe.Coerce (unsafeCoerce) import qualified Data.Aeson as Aeson @@ -21,13 +31,14 @@ import qualified Data.Text as Text.Strict import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Vector as Vector.Boxed -import qualified Data.Vector.Storable as Vector.Storable import qualified Data.Vector.Primitive as Vector.Primitive +import qualified Data.Vector.Storable as Vector.Storable import Debug.RecoverRTTI import Test.QuickCheck +import Test.RecoverRTTI.Classifier.Equality () import Test.RecoverRTTI.Globals {------------------------------------------------------------------------------- @@ -41,7 +52,7 @@ Arbitrary support for the primitive types -------------------------------------------------------------------------------} -primSatisfiesArbitrary :: PrimClassifier a -> Dict Arbitrary a +primSatisfiesArbitrary :: PrimClassifier a -> Dict (Compose Arbitrary Wrap) a primSatisfiesArbitrary = primSatisfies arbitraryPrimClassifier :: Gen (Some PrimClassifier) @@ -154,26 +165,52 @@ C_Vector_PrimitiveM -> () {------------------------------------------------------------------------------- - Orphan instances --------------------------------------------------------------------------------} + Arbitrary instances for specific types + -------------------------------------------------------------------------------} -instance Arbitrary BS.Strict.ByteString where - arbitrary = BS.Strict.pack <$> arbitrary +-- | 'Wrap' makes it possible to override an 'Arbitrary' instance if needed. +newtype Wrap a = Wrap { unwrap :: a } -instance Arbitrary BS.Lazy.ByteString where - arbitrary = BS.Lazy.pack <$> arbitrary +deriving newtype instance Arbitrary (Wrap ()) +deriving newtype instance Arbitrary (Wrap Bool) +deriving newtype instance Arbitrary (Wrap Char) +deriving newtype instance Arbitrary (Wrap Double) +deriving newtype instance Arbitrary (Wrap Float) +deriving newtype instance Arbitrary (Wrap Int) +deriving newtype instance Arbitrary (Wrap Int16) +deriving newtype instance Arbitrary (Wrap Int32) +deriving newtype instance Arbitrary (Wrap Int64) +deriving newtype instance Arbitrary (Wrap Int8) +deriving newtype instance Arbitrary (Wrap Integer) +deriving newtype instance Arbitrary (Wrap IntSet) +deriving newtype instance Arbitrary (Wrap Ordering) +deriving newtype instance Arbitrary (Wrap String) +deriving newtype instance Arbitrary (Wrap Word) +deriving newtype instance Arbitrary (Wrap Word16) +deriving newtype instance Arbitrary (Wrap Word32) +deriving newtype instance Arbitrary (Wrap Word64) +deriving newtype instance Arbitrary (Wrap Word8) -instance Arbitrary BS.Short.ShortByteString where - arbitrary = BS.Short.pack <$> arbitrary +instance Arbitrary (Wrap BS.Strict.ByteString) where + arbitrary = Wrap . BS.Strict.pack <$> arbitrary -instance Arbitrary Text.Strict.Text where - arbitrary = Text.Strict.pack <$> arbitrary +instance Arbitrary (Wrap BS.Lazy.ByteString) where + arbitrary = Wrap . BS.Lazy.pack <$> arbitrary -instance Arbitrary Text.Lazy.Text where - arbitrary = Text.Lazy.pack <$> arbitrary +instance Arbitrary (Wrap BS.Short.ShortByteString) where + arbitrary = Wrap . BS.Short.pack <$> arbitrary -instance Arbitrary Aeson.Value where - arbitrary = choose (0, 10) >>= go +instance Arbitrary (Wrap Text.Strict.Text) where + arbitrary = Wrap . Text.Strict.pack <$> arbitrary + +instance Arbitrary (Wrap Text.Lazy.Text) where + arbitrary = Wrap . Text.Lazy.pack <$> arbitrary + +-- | aeson >= 2.0.3.0 does define an 'Arbitrary' instance for 'Aeson.Value', +-- but it generates values that are too big, which cause the size sanity check +-- on the generator 'prop_showGenerated' to start to fail. +instance Arbitrary (Wrap Aeson.Value) where + arbitrary = choose (0, 10) >>= fmap Wrap . go where go :: Int -> Gen Aeson.Value go 0 = oneof nonRecursive @@ -194,19 +231,19 @@ , do n <- choose (0, 5) Aeson.object <$> replicateM n ( (Aeson..=) - <$> fieldName + <$> (fromString <$> fieldName) <*> go (sz `div` n) ) ] -- We're not interested in testing crazy values - fieldName :: Gen Text.Strict.Text + fieldName :: Gen String fieldName = elements ["a", "b", "c"] -- | Rather than trying to be clever here, we just generate a handful of -- examples in different categories. -instance Arbitrary SomeFun where - arbitrary = elements [ +instance Arbitrary (Wrap SomeFun) where + arbitrary = fmap Wrap $ elements [ -- Parametrically polymorphic function fun (id :: Int -> Int) , fun (const :: Int -> Bool -> Int) @@ -221,8 +258,8 @@ fun :: (a -> b) -> SomeFun fun = unsafeCoerce -instance Arbitrary SomeStorableVector where - arbitrary = elements [ +instance Arbitrary (Wrap SomeStorableVector) where + arbitrary = fmap Wrap $ elements [ some $ Vector.Storable.fromList ([1, 2, 3] :: [Int]) , some $ Vector.Storable.fromList ("abc" :: String) ] @@ -230,8 +267,8 @@ some :: Vector.Storable.Vector a -> SomeStorableVector some = unsafeCoerce -instance Arbitrary SomePrimitiveVector where - arbitrary = elements [ +instance Arbitrary (Wrap SomePrimitiveVector) where + arbitrary = fmap Wrap $ elements [ some $ Vector.Primitive.fromList ([1, 2, 3] :: [Int]) , some $ Vector.Primitive.fromList ("abc" :: String) ] @@ -243,50 +280,20 @@ For the mutable variables, we just use the one global example -------------------------------------------------------------------------------} -instance Arbitrary SomeSTRef where - arbitrary = return exampleSTRef - -instance Arbitrary SomeTVar where - arbitrary = return exampleTVar - -instance Arbitrary SomeMVar where - arbitrary = return exampleMVar - -instance Arbitrary SomePrimArrayM where - arbitrary = return examplePrimArrayM - -instance Arbitrary SomeStorableVectorM where - arbitrary = return exampleStorableVectorM - -instance Arbitrary SomePrimitiveVectorM where - arbitrary = return examplePrimitiveVectorM - -{------------------------------------------------------------------------------- - Orphan equality instances --------------------------------------------------------------------------------} - --- | Degenerate 'Eq' instance for functions that always says 'True' --- --- When we compare values up to the coercion returned by 'reclassify', we need --- an 'Eq' instance. We can't compare functions in any meaningful way though, --- and so we just return 'True' here no matter what. --- --- This is an orphan defined in the test suite only, so that users of the --- library don't have acccess to this (misleading) instance. -instance Eq SomeFun where - _ == _ = True +instance Arbitrary (Wrap SomeSTRef) where + arbitrary = return $ Wrap exampleSTRef -instance Eq SomePrimArrayM where - _ == _ = True +instance Arbitrary (Wrap SomeTVar) where + arbitrary = return $ Wrap exampleTVar -instance Eq SomeStorableVector where - _ == _ = True +instance Arbitrary (Wrap SomeMVar) where + arbitrary = return $ Wrap exampleMVar -instance Eq SomeStorableVectorM where - _ == _ = True +instance Arbitrary (Wrap SomePrimArrayM) where + arbitrary = return $ Wrap examplePrimArrayM -instance Eq SomePrimitiveVector where - _ == _ = True +instance Arbitrary (Wrap SomeStorableVectorM) where + arbitrary = return $ Wrap exampleStorableVectorM -instance Eq SomePrimitiveVectorM where - _ == _ = True +instance Arbitrary (Wrap SomePrimitiveVectorM) where + arbitrary = return $ Wrap examplePrimitiveVectorM 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 @@ -70,7 +70,7 @@ arbitrary `suchThat` (not . null) -- empty string classified as @[Void]@ primDepGen c = case (primSatisfiesArbitrary c, canShowPrim c, canComparePrim c) of - (Dict, Dict, Dict) -> arbitraryDepGen (C_Prim c) + (Dict, Dict, Dict) -> DepGen (C_Prim c) $ unwrap <$> SG.arbitrary {------------------------------------------------------------------------------- Bundle a dependent generator with a lifting function 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,8 +1,17 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + module Test.RecoverRTTI.Sanity (tests) where +import Data.SOP.BasicFunctors +import GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) + import Debug.RecoverRTTI import Test.Tasty +import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.RecoverRTTI.ConcreteClassifier @@ -12,7 +21,9 @@ tests :: TestTree tests = testGroup "Test.RecoverRTTI.Sanity" [ - testProperty "typeSize" prop_typeSize + testProperty "typeSize" prop_typeSize + , testCase "derivingVia" test_derivingVia + , testCase "BoxAnythingToString" test_BoxAnythingToString ] prop_typeSize :: Property @@ -22,3 +33,38 @@ counterexample ("classifier: " ++ show classifier) $ counterexample ("size: " ++ show (sizeConcrete classifier)) $ sizeConcrete classifier <= 100 + +{------------------------------------------------------------------------------- + Deriving-via support +-------------------------------------------------------------------------------} + +data T1 = T1 Int Bool + +data T2 = T2 T1 + deriving Show via AnythingToString T2 + +test_derivingVia :: Assertion +test_derivingVia = assertEqual "" "T2 (T1 1 True)" $ show (T2 (T1 1 True)) + +{------------------------------------------------------------------------------- + BoxAnythingToString +-------------------------------------------------------------------------------} + +data T3 f = T3 [f Any] + +deriving instance Show a => Show (T3 (K a)) + +t3BadExample :: T3 I +t3BadExample = T3 [unsafeCoerce (1 :: Int), unsafeCoerce False] + +t3GoodExample :: T3 (K BoxAnything) +t3GoodExample = T3 [K $ BoxAnything (1 :: Int), K $ BoxAnything 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