recover-rtti 0.4.0.0 → 0.4.1.0

raw patch · 10 files changed

+287/−85 lines, 10 filesdep +tasty-hunitdep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit

Dependency ranges changed: aeson, base, bytestring, ghc-heap, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +1/−1
• recover-rtti.cabal +16/−11
• src/Debug/RecoverRTTI.hs +8/−0
• src/Debug/RecoverRTTI/Classify.hs +3/−0
• src/Debug/RecoverRTTI/Debugging.hs +97/−0
• tests/Test/RecoverRTTI/Classifier/Equality.hs +31/−1
• tests/Test/RecoverRTTI/Prim.hs +77/−70
• tests/Test/RecoverRTTI/QuickCheck/DepGen.hs +1/−1
• tests/Test/RecoverRTTI/Sanity.hs +47/−1

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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