recover-rtti 0.2.0.0 → 0.2.1.0
raw patch · 12 files changed
+544/−304 lines, 12 filesdep +unordered-containersPVP ok
version bump matches the API change (PVP)
Dependencies added: unordered-containers
API changes (from Hackage documentation)
+ Debug.RecoverRTTI: [C_HM_Array] :: MaybeF Classified a -> Classifier (Array a)
+ Debug.RecoverRTTI: [C_HashMap] :: MaybePairF Classified a b -> Classifier (HashMap a b)
+ Debug.RecoverRTTI: [C_HashSet] :: Classified a -> Classifier (HashSet a)
+ Debug.RecoverRTTI: [C_Vector_Boxed] :: MaybeF Classified a -> Classifier (Vector a)
Files
- CHANGELOG.md +4/−0
- recover-rtti.cabal +13/−10
- src/Debug/RecoverRTTI.hs +1/−1
- src/Debug/RecoverRTTI/Classifier.hs +29/−15
- src/Debug/RecoverRTTI/Classify.hs +117/−32
- src/Debug/RecoverRTTI/ClosureTree.hs +2/−2
- src/Debug/RecoverRTTI/Modules.hs +74/−48
- tests/Test/RecoverRTTI/Arbitrary.hs +159/−119
- tests/Test/RecoverRTTI/Classify.hs +37/−18
- tests/Test/RecoverRTTI/ConcreteClassifier.hs +67/−47
- tests/Test/RecoverRTTI/Orphans.hs +8/−0
- tests/Test/RecoverRTTI/Staged.hs +33/−12
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for recover-rtti +## 0.2.1.0 -- 2021-03-17++* Add support for unordered-containers and boxed vectors.+ ## 0.2.0.0 -- 2021-03-15 * Reorganize module structure (primarily to improve Haddocks)
recover-rtti.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: recover-rtti-version: 0.2.0.0+version: 0.2.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@@ -39,15 +39,17 @@ Debug.RecoverRTTI.Util Debug.RecoverRTTI.Wrappers - build-depends: base >= 4.13 && < 4.16- , aeson >= 1.5 && < 1.6- , bytestring >= 0.10 && < 0.11- , containers >= 0.6 && < 0.7- , ghc-heap >= 8.8 && < 9.1- , mtl >= 2.2 && < 2.3- , sop-core >= 0.5 && < 0.6- , stm >= 2.5 && < 2.6- , text >= 1.2 && < 1.3+ build-depends: base >= 4.13 && < 4.16+ , aeson >= 1.5 && < 1.6+ , bytestring >= 0.10 && < 0.11+ , containers >= 0.6 && < 0.7+ , ghc-heap >= 8.8 && < 9.1+ , mtl >= 2.2 && < 2.3+ , sop-core >= 0.5 && < 0.6+ , stm >= 2.5 && < 2.6+ , text >= 1.2 && < 1.3+ , unordered-containers+ , vector hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -81,6 +83,7 @@ , tasty , tasty-quickcheck , text+ , unordered-containers , vector ghc-options: -Wall -Wno-orphans
src/Debug/RecoverRTTI.hs view
@@ -26,7 +26,7 @@ , Some(..) -- ** Constructor information , Constr(..)- -- ** Type-level constructor informatino+ -- ** Type-level constructor information , ConstrPkg , ConstrModl , ConstrName
src/Debug/RecoverRTTI/Classifier.hs view
@@ -14,6 +14,8 @@ ) where import Data.Aeson (Value)+import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet) import Data.Int import Data.IntMap (IntMap) import Data.IntSet (IntSet)@@ -27,11 +29,13 @@ import Data.Void import Data.Word -import qualified Data.ByteString as BS.Strict-import qualified Data.ByteString.Lazy as BS.Lazy-import qualified Data.ByteString.Short as BS.Short-import qualified Data.Text as Text.Strict-import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.ByteString as BS.Strict+import qualified Data.ByteString.Lazy as BS.Lazy+import qualified Data.ByteString.Short as BS.Short+import qualified Data.HashMap.Internal.Array as HashMap (Array)+import qualified Data.Text as Text.Strict+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Vector as Vector.Boxed import Debug.RecoverRTTI.Constr import Debug.RecoverRTTI.Tuple@@ -94,17 +98,27 @@ C_Value :: Classifier Value -- 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. - C_Maybe :: MaybeF Classified a -> Classifier (Maybe a)- C_Either :: EitherF Classified a b -> Classifier (Either a b)- C_List :: MaybeF Classified a -> Classifier [a]- C_Ratio :: Classified a -> Classifier (Ratio a)- C_Set :: MaybeF Classified a -> Classifier (Set a)- C_Map :: MaybePairF Classified a b -> Classifier (Map a b)- C_IntSet :: Classifier IntSet- C_IntMap :: MaybeF Classified a -> Classifier (IntMap a)- C_Sequence :: MaybeF Classified a -> Classifier (Seq a)- C_Tree :: Classified a -> Classifier (Tree a)+ C_Maybe :: MaybeF Classified a -> Classifier (Maybe a)+ C_Either :: EitherF Classified a b -> Classifier (Either a b)+ C_List :: MaybeF Classified a -> Classifier [a]+ C_Ratio :: Classified a -> Classifier (Ratio a)+ C_Set :: MaybeF Classified a -> Classifier (Set a)+ C_Map :: MaybePairF Classified a b -> Classifier (Map a b)+ C_IntSet :: Classifier IntSet+ C_IntMap :: MaybeF Classified a -> Classifier (IntMap a)+ C_Sequence :: MaybeF Classified a -> Classifier (Seq a)+ C_Tree :: Classified a -> Classifier (Tree a)+ C_HashSet :: Classified a -> Classifier (HashSet a)+ C_HashMap :: MaybePairF Classified a b -> Classifier (HashMap a b)+ C_HM_Array :: MaybeF Classified a -> Classifier (HashMap.Array a)+ C_Vector_Boxed :: MaybeF Classified a -> Classifier (Vector.Boxed.Vector a) C_Tuple :: (SListI xs, IsValidSize (Length xs))
src/Debug/RecoverRTTI/Classify.hs view
@@ -23,6 +23,7 @@ ) where import Control.Monad.Except+import Data.HashMap.Lazy (HashMap) import Data.IntMap (IntMap) import Data.Map (Map) import Data.Sequence (Seq)@@ -30,17 +31,21 @@ import Data.SOP import Data.SOP.Dict import Data.Tree (Tree)+import GHC.Exts.Heap (Closure) import GHC.Real import GHC.Stack-import GHC.Exts.Heap (Closure) import System.IO.Unsafe (unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) -import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Tree as Tree+import qualified Data.HashMap.Internal.Array as HashMap (Array)+import qualified Data.HashMap.Internal.Array as HashMap.Array+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Tree as Tree+import qualified Data.Vector as Vector.Boxed import Debug.RecoverRTTI.Classifier import Debug.RecoverRTTI.Constr@@ -198,7 +203,30 @@ case liftValidSize validSize of Dict -> mustBe <$> classifyTuple ptrs + -- HashMap --+ -- This could also be a HashSet, which is a newtype around a HashMap;+ -- we distinguish in 'classifyHashMap'.+ (inKnownModule DataHashMapInternal -> Just "Empty") ->+ mustBe <$> classifyHashMap (unsafeCoerce x)+ (inKnownModule DataHashMapInternal -> Just "BitmapIndexed") ->+ mustBe <$> classifyHashMap (unsafeCoerce x)+ (inKnownModule DataHashMapInternal -> Just "Leaf") ->+ mustBe <$> classifyHashMap (unsafeCoerce x)+ (inKnownModule DataHashMapInternal -> Just "Full") ->+ mustBe <$> classifyHashMap (unsafeCoerce x)+ (inKnownModule DataHashMapInternal -> Just "Collision") ->+ mustBe <$> classifyHashMap (unsafeCoerce x)++ -- HashMap's internal Array type+ (inKnownModule DataHashMapInternalArray -> Just "Array") ->+ mustBe <$> classifyHMArray (unsafeCoerce x)++ -- Boxed vectors+ (inKnownModule DataVector -> Just "Vector") ->+ mustBe <$> classifyVectorBoxed (unsafeCoerce x)++ -- -- Reference cells -- @@ -245,7 +273,9 @@ Classification for compound types -------------------------------------------------------------------------------} -classifyMaybe :: Maybe a -> ExceptT Closure IO (Classifier (Maybe a))+classifyMaybe ::+ Maybe a+ -> ExceptT Closure IO (Classifier (Maybe a)) classifyMaybe x = case x of Nothing -> return $ mustBe $ C_Maybe FNothing@@ -253,7 +283,9 @@ cx <- classifyIO x' return $ mustBe $ C_Maybe (FJust (Classified cx x')) -classifyEither :: Either a b -> ExceptT Closure IO (Classifier (Either a b))+classifyEither ::+ Either a b+ -> ExceptT Closure IO (Classifier (Either a b)) classifyEither x = case x of Left x' -> do@@ -263,7 +295,9 @@ cy <- classifyIO y' return $ mustBe $ C_Either (FRight (Classified cy y')) -classifyList :: [a] -> ExceptT Closure IO (Classifier [a])+classifyList ::+ [a]+ -> ExceptT Closure IO (Classifier [a]) classifyList x = case x of [] -> return $ mustBe $ C_List FNothing@@ -273,12 +307,16 @@ C_Char -> mustBe $ C_String _otherwise -> mustBe $ C_List (FJust (Classified cx x')) -classifyRatio :: Ratio a -> ExceptT Closure IO (Classifier (Ratio a))+classifyRatio ::+ Ratio a+ -> ExceptT Closure IO (Classifier (Ratio a)) classifyRatio (x' :% _) = do cx <- classifyIO x' return $ mustBe $ C_Ratio (Classified cx x') -classifySet :: Set a -> ExceptT Closure IO (Classifier (Set a))+classifySet ::+ Set a+ -> ExceptT Closure IO (Classifier (Set a)) classifySet x = case Set.lookupMin x of Nothing -> return $ mustBe $ C_Set FNothing@@ -286,16 +324,20 @@ cx <- classifyIO x' return $ mustBe $ C_Set (FJust (Classified cx x')) -classifyMap :: Map a b -> ExceptT Closure IO (Classifier (Map a b))+classifyMap ::+ Map a b+ -> ExceptT Closure IO (Classifier (Map a b)) classifyMap x =- case Map.lookupMin x of- Nothing -> return $ mustBe $ C_Map FNothingPair- Just (x', y') -> do- cx <- classifyIO x'- cy <- classifyIO y'- return $ mustBe $ C_Map (FJustPair (Classified cx x') (Classified cy y'))+ case Map.lookupMin x of+ Nothing -> return $ mustBe $ C_Map FNothingPair+ Just (x', y') -> do+ cx <- classifyIO x'+ cy <- classifyIO y'+ return $ mustBe $ C_Map (FJustPair (Classified cx x') (Classified cy y')) -classifyIntMap :: IntMap a -> ExceptT Closure IO (Classifier (IntMap a))+classifyIntMap ::+ IntMap a+ -> ExceptT Closure IO (Classifier (IntMap a)) classifyIntMap x = case IntMap.minView x of Nothing -> return $ mustBe $ C_IntMap FNothing@@ -303,7 +345,9 @@ cx <- classifyIO x' return $ mustBe $ C_IntMap (FJust (Classified cx x')) -classifySequence :: Seq a -> ExceptT Closure IO (Classifier (Seq a))+classifySequence ::+ Seq a+ -> ExceptT Closure IO (Classifier (Seq a)) classifySequence x = case Seq.viewl x of Seq.EmptyL -> return $ mustBe $ C_Sequence FNothing@@ -311,13 +355,50 @@ cx <- classifyIO x' return $ mustBe $ C_Sequence (FJust (Classified cx x')) -classifyTree :: Tree a -> ExceptT Closure IO (Classifier (Tree a))+classifyTree ::+ Tree a+ -> ExceptT Closure IO (Classifier (Tree a)) classifyTree x = case x of Tree.Node x' _ -> do cx <- classifyIO x' return $ mustBe $ C_Tree (Classified cx x') +classifyHashMap ::+ HashMap a b+ -> ExceptT Closure IO (Classifier (HashMap a b))+classifyHashMap x =+ case HashMap.toList x of+ [] -> return $ mustBe $ C_HashMap FNothingPair+ ((x', y'):_) -> do+ cx <- classifyIO x'+ cy <- classifyIO y'+ return $ case cy of+ C_Unit -> mustBe $ C_HashSet (Classified cx x')+ _otherwise -> mustBe $ C_HashMap (FJustPair (Classified cx x') (Classified cy y'))++classifyHMArray ::+ HashMap.Array a+ -> ExceptT Closure IO (Classifier (Tree a))+classifyHMArray x =+ if HashMap.Array.length x == 0+ then return $ mustBe $ C_HM_Array FNothing+ else do+ let x' = HashMap.Array.index x 0+ cx <- classifyIO x'+ return $ mustBe $ C_HM_Array (FJust (Classified cx x'))++classifyVectorBoxed ::+ Vector.Boxed.Vector a+ -> ExceptT Closure IO (Classifier (Vector.Boxed.Vector a))+classifyVectorBoxed x =+ if Vector.Boxed.length x == 0+ then return $ mustBe $ C_Vector_Boxed FNothing+ else do+ let x' = Vector.Boxed.head x+ cx <- classifyIO x'+ return $ mustBe $ C_Vector_Boxed (FJust (Classified cx x'))+ classifyTuple :: (SListI xs, IsValidSize (Length xs)) => NP (K Box) xs@@ -412,7 +493,7 @@ -- what the /derived/ show instance would have done. -- * Record field names are not known at runtime, so they are not shown. -- * UNPACKed data is not visible to this library (if you compile with @-O0@--- @gch@ will not unpack data, so that might be a workaround if necessary).+-- @ghc@ will not unpack data, so that might be a workaround if necessary). -- -- If classification fails, we show the actual closure. anythingToString :: forall a. a -> String@@ -504,16 +585,20 @@ -- Compound -- - go (C_Maybe c) = goMaybeF c- go (C_Either c) = goEitherF c- go (C_List c) = goMaybeF c- go (C_Ratio c) = goF c- go (C_Set c) = goMaybeF c- go (C_Map c) = goMaybePairF c- go C_IntSet = Dict- go (C_IntMap c) = goMaybeF c- go (C_Sequence c) = goMaybeF c- go (C_Tree c) = goF c+ go (C_Maybe c) = goMaybeF c+ go (C_Either c) = goEitherF c+ go (C_List c) = goMaybeF c+ go (C_Ratio c) = goF c+ go (C_Set c) = goMaybeF c+ go (C_Map c) = goMaybePairF c+ go C_IntSet = Dict+ go (C_IntMap c) = goMaybeF c+ go (C_Sequence c) = goMaybeF c+ go (C_Tree c) = goF c+ go (C_HashSet c) = goF c+ go (C_HashMap c) = goMaybePairF c+ go (C_HM_Array c) = goMaybeF c+ go (C_Vector_Boxed c) = goMaybeF c go (C_Tuple (Classifiers cs)) = case all_NP (hmap (canShowClassified . classifiedType) cs) of
src/Debug/RecoverRTTI/ClosureTree.hs view
@@ -14,8 +14,8 @@ showClosureTree = \d -> go d 0 . asBox where go :: Int -> Int -> Box -> IO String- go 0 _ _ = return ""- go d i x@(Box !_) = do+ go 0 _ _ = return ""+ go d i x = do closure <- getBoxedClosureData x render closure <$> mapM (go (d - 1) (i + 2)) (allClosures closure) where
src/Debug/RecoverRTTI/Modules.hs view
@@ -33,6 +33,8 @@ | PkgGhcBignum | PkgContainers | PkgAeson+ | PkgUnorderedContainers+ | PkgVector data family KnownModule (pkg :: KnownPkg) @@ -41,23 +43,27 @@ -------------------------------------------------------------------------------} data instance Sing (pkg :: KnownPkg) where- SGhcPrim :: Sing 'PkgGhcPrim- SBase :: Sing 'PkgBase- SByteString :: Sing 'PkgByteString- SText :: Sing 'PkgText- SIntegerWiredIn :: Sing 'PkgIntegerWiredIn- SGhcBignum :: Sing 'PkgGhcBignum- SContainers :: Sing 'PkgContainers- SAeson :: Sing 'PkgAeson+ SGhcPrim :: Sing 'PkgGhcPrim+ SBase :: Sing 'PkgBase+ SByteString :: Sing 'PkgByteString+ SText :: Sing 'PkgText+ SIntegerWiredIn :: Sing 'PkgIntegerWiredIn+ SGhcBignum :: Sing 'PkgGhcBignum+ SContainers :: Sing 'PkgContainers+ SAeson :: Sing 'PkgAeson+ SUnorderedContainers :: Sing 'PkgUnorderedContainers+ SVector :: Sing 'PkgVector -instance SingI 'PkgGhcPrim where sing = SGhcPrim-instance SingI 'PkgBase where sing = SBase-instance SingI 'PkgByteString where sing = SByteString-instance SingI 'PkgText where sing = SText-instance SingI 'PkgIntegerWiredIn where sing = SIntegerWiredIn-instance SingI 'PkgGhcBignum where sing = SGhcBignum-instance SingI 'PkgContainers where sing = SContainers-instance SingI 'PkgAeson where sing = SAeson+instance SingI 'PkgGhcPrim where sing = SGhcPrim+instance SingI 'PkgBase where sing = SBase+instance SingI 'PkgByteString where sing = SByteString+instance SingI 'PkgText where sing = SText+instance SingI 'PkgIntegerWiredIn where sing = SIntegerWiredIn+instance SingI 'PkgGhcBignum where sing = SGhcBignum+instance SingI 'PkgContainers where sing = SContainers+instance SingI 'PkgAeson where sing = SAeson+instance SingI 'PkgUnorderedContainers where sing = SUnorderedContainers+instance SingI 'PkgVector where sing = SVector {------------------------------------------------------------------------------- Modules in @ghc-pri@@@ -132,6 +138,21 @@ DataAesonTypesInternal {-------------------------------------------------------------------------------+ Modules in @unordered-containers@+-------------------------------------------------------------------------------}++data instance KnownModule 'PkgUnorderedContainers =+ DataHashMapInternal+ | DataHashMapInternalArray++{-------------------------------------------------------------------------------+ Modules in @vector@+-------------------------------------------------------------------------------}++data instance KnownModule 'PkgVector =+ DataVector++{------------------------------------------------------------------------------- Matching -------------------------------------------------------------------------------} @@ -155,37 +176,42 @@ go _ _ _otherClosure = Nothing namePkg :: Sing (pkg :: KnownPkg) -> String- namePkg SGhcPrim = "ghc-prim"- namePkg SBase = "base"- namePkg SByteString = "bytestring"- namePkg SText = "text"- namePkg SIntegerWiredIn = "integer-wired-in"- namePkg SGhcBignum = "ghc-bignum"- namePkg SContainers = "containers"- namePkg SAeson = "aeson"+ namePkg SGhcPrim = "ghc-prim"+ namePkg SBase = "base"+ namePkg SByteString = "bytestring"+ namePkg SText = "text"+ namePkg SIntegerWiredIn = "integer-wired-in"+ namePkg SGhcBignum = "ghc-bignum"+ namePkg SContainers = "containers"+ namePkg SAeson = "aeson"+ namePkg SUnorderedContainers = "unordered-containers"+ namePkg SVector = "vector" nameModl :: Sing (pkg :: KnownPkg) -> KnownModule pkg -> String- nameModl SGhcPrim GhcTypes = "GHC.Types"- nameModl SGhcPrim GhcTuple = "GHC.Tuple"- nameModl SBase GhcInt = "GHC.Int"- nameModl SBase GhcWord = "GHC.Word"- nameModl SBase GhcSTRef = "GHC.STRef"- nameModl SBase GhcMVar = "GHC.MVar"- nameModl SBase GhcConcSync = "GHC.Conc.Sync"- nameModl SBase GhcMaybe = "GHC.Maybe"- nameModl SBase GhcReal = "GHC.Real"- nameModl SBase DataEither = "Data.Either"- nameModl SByteString DataByteStringInternal = "Data.ByteString.Internal"- nameModl SByteString DataByteStringLazyInternal = "Data.ByteString.Lazy.Internal"- nameModl SByteString DataByteStringShortInternal = "Data.ByteString.Short.Internal"- nameModl SText DataTextInternal = "Data.Text.Internal"- nameModl SText DataTextInternalLazy = "Data.Text.Internal.Lazy"- nameModl SIntegerWiredIn GhcIntegerType = "GHC.Integer.Type"- nameModl SGhcBignum GhcNumInteger = "GHC.Num.Integer"- nameModl SContainers DataSetInternal = "Data.Set.Internal"- nameModl SContainers DataMapInternal = "Data.Map.Internal"- nameModl SContainers DataIntSetInternal = "Data.IntSet.Internal"- nameModl SContainers DataIntMapInternal = "Data.IntMap.Internal"- nameModl SContainers DataSequenceInternal = "Data.Sequence.Internal"- nameModl SContainers DataTree = "Data.Tree"- nameModl SAeson DataAesonTypesInternal = "Data.Aeson.Types.Internal"+ nameModl SGhcPrim GhcTypes = "GHC.Types"+ nameModl SGhcPrim GhcTuple = "GHC.Tuple"+ nameModl SBase GhcInt = "GHC.Int"+ nameModl SBase GhcWord = "GHC.Word"+ nameModl SBase GhcSTRef = "GHC.STRef"+ nameModl SBase GhcMVar = "GHC.MVar"+ nameModl SBase GhcConcSync = "GHC.Conc.Sync"+ nameModl SBase GhcMaybe = "GHC.Maybe"+ nameModl SBase GhcReal = "GHC.Real"+ nameModl SBase DataEither = "Data.Either"+ nameModl SByteString DataByteStringInternal = "Data.ByteString.Internal"+ nameModl SByteString DataByteStringLazyInternal = "Data.ByteString.Lazy.Internal"+ nameModl SByteString DataByteStringShortInternal = "Data.ByteString.Short.Internal"+ nameModl SText DataTextInternal = "Data.Text.Internal"+ nameModl SText DataTextInternalLazy = "Data.Text.Internal.Lazy"+ nameModl SIntegerWiredIn GhcIntegerType = "GHC.Integer.Type"+ nameModl SGhcBignum GhcNumInteger = "GHC.Num.Integer"+ nameModl SContainers DataSetInternal = "Data.Set.Internal"+ nameModl SContainers DataMapInternal = "Data.Map.Internal"+ nameModl SContainers DataIntSetInternal = "Data.IntSet.Internal"+ nameModl SContainers DataIntMapInternal = "Data.IntMap.Internal"+ nameModl SContainers DataSequenceInternal = "Data.Sequence.Internal"+ nameModl SContainers DataTree = "Data.Tree"+ nameModl SAeson DataAesonTypesInternal = "Data.Aeson.Types.Internal"+ nameModl SUnorderedContainers DataHashMapInternal = "Data.HashMap.Internal"+ nameModl SUnorderedContainers DataHashMapInternalArray = "Data.HashMap.Internal.Array"+ nameModl SVector DataVector = "Data.Vector"
tests/Test/RecoverRTTI/Arbitrary.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}@@ -36,18 +37,21 @@ import System.IO.Unsafe (unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) -import qualified Data.Aeson as Aeson-import qualified Data.ByteString as BS.Strict-import qualified Data.ByteString.Lazy as BS.Lazy-import qualified Data.ByteString.Short as BS.Short-import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Text as Text.Strict-import qualified Data.Text.Lazy as Text.Lazy-import qualified Data.Tree as Tree-import qualified Data.Vector as Vector+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS.Strict+import qualified Data.ByteString.Lazy as BS.Lazy+import qualified Data.ByteString.Short as BS.Short+import qualified Data.HashMap.Internal.Array as HashMap.Array+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Text as Text.Strict+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Tree as Tree+import qualified Data.Vector as Vector.Boxed import Test.QuickCheck hiding (classify, NonEmpty) @@ -71,6 +75,9 @@ ignoreSize :: Gen a -> SizedGen a ignoreSize gen = SizedGen $ \_sz -> gen +arbitrarySizedGen :: Arbitrary a => SizedGen a+arbitrarySizedGen = ignoreSize arbitrary+ {------------------------------------------------------------------------------- Arbitrary instance -------------------------------------------------------------------------------}@@ -196,13 +203,7 @@ (\case FJust CC_Char -> CC_String c -> CC_List c) (return [])- (\(SizedGen gen) -> SizedGen $ \valSz -> do- -- Pick number of list elements (don't generate empty list)- n <- choose (1, 5)-- -- Then divide total size of each list element- vectorOf n (gen (valSz `div` n))- )+ (genListLike id) a ) @@ -236,11 +237,7 @@ genMaybeF CC_Set (return Set.empty)- -- Same strategy as for lists- (\(SizedGen gen) -> SizedGen $ \valSz -> do- n <- choose (1, 5)- Set.fromList <$> vectorOf n (gen (valSz `div` n))- )+ (genListLike Set.fromList) (defaultClassifiedGen CC_Int) ) @@ -251,13 +248,7 @@ genMaybePairF CC_Map (return Map.empty)- (\(SizedGen genX) (SizedGen genY) -> SizedGen $ \valSz -> do- n <- choose (1, 5)- Map.fromList <$> vectorOf n (- (,) <$> genX (valSz `div` n `div` 2)- <*> genY (valSz `div` n `div` 2)- )- )+ (genMapLike Map.fromList) (defaultClassifiedGen CC_Int) b )@@ -271,13 +262,7 @@ genMaybeF CC_IntMap (return IntMap.empty)- (\(SizedGen genY) -> SizedGen $ \valSz -> do- n <- choose (1, 5)- IntMap.fromList <$> vectorOf n (- (,) <$> arbitrary- <*> genY (valSz `div` n)- )- )+ (genMapLike IntMap.fromList arbitrarySizedGen) b ) @@ -287,25 +272,63 @@ genMaybeF CC_Sequence (return Seq.empty)- (\(SizedGen genX) -> SizedGen $ \valSz -> do- n <- choose (1, 5)- Seq.fromList <$> vectorOf n (genX (valSz `div` n))- )+ (genListLike Seq.fromList) a ) -- Tree , guard (typSz >= 1) >> (return $ do Some a <- arbitraryClassifiedGen (typSz - 1)- genF- CC_Tree- (\(SizedGen genX) -> SizedGen $ \valSz -> do- n <- choose (1, 5)- mkSomeTree <$> vectorOf n (genX (valSz `div` n))- )+ genF CC_Tree (genListLike mkSomeTree) a+ )++ -- HashSet+ -- Like Set, we need an Ord instance on the elements, so we pick Int+ -- genListLike never generates the empty list, which is important:+ -- an empty 'HashSet' would be misclassified as a 'HashMap'.+ , (return $+ genF+ CC_HashSet+ (genListLike HashSet.fromList)+ (defaultClassifiedGen CC_Int)+ )++ -- HashMap+ , guard (typSz >= 1) >> (return $ do+ -- A map with @()@ values is classified as a @HashSet@+ let isUnit :: Some ClassifiedGen -> Bool+ isUnit (Some (ClassifiedGen CC_Unit _)) = True+ isUnit _otherwise = False+ Some b <- arbitraryClassifiedGen (typSz - 1) `suchThat` (not . isUnit)+ genMaybePairF+ CC_HashMap+ (return HashMap.empty)+ (genMapLike HashMap.fromList)+ (defaultClassifiedGen CC_Int)+ b+ )++ -- HashMap's internal array type+ , guard (typSz >= 1) >> (return $ do+ let mkArray xs = HashMap.Array.fromList (length xs) xs+ Some a <- arbitraryClassifiedGen (typSz - 1)+ genMaybeF+ CC_HM_Array+ (return $ mkArray [])+ (genListLike mkArray) a ) + -- Boxed vectors+ , guard (typSz >= 1) >> (return $ do+ Some a <- arbitraryClassifiedGen (typSz - 1)+ genMaybeF+ CC_Vector_Boxed+ (return Vector.Boxed.empty)+ (genListLike Vector.Boxed.fromList)+ a+ )+ -- -- User-defined --@@ -326,11 +349,7 @@ genMaybeF CC_User_Rec (return RNil)- (\gen -> SizedGen $ \valSz -> do- -- Similar strategy as for lists- n <- choose (1, 5)- recursiveFromList <$> vectorOf n (runSized (valSz `div` n) gen)- )+ (genListLike recursiveFromList) a ) @@ -356,60 +375,6 @@ ) ] - genMaybeF ::- ( forall x. Show x => Show (f x)- , forall x. Eq x => Eq (f x)- )- => (forall x. MaybeF ConcreteClassifier x -> ConcreteClassifier (f x))- -> Gen (f Void)- -> (SizedGen a -> SizedGen (f a))- -> ClassifiedGen a -> Gen (Some ClassifiedGen)- genMaybeF cc genNothing genJust (ClassifiedGen cA genA) =- elements [- Some $ ClassifiedGen (cc FNothing) (ignoreSize $ genNothing)- , Some $ ClassifiedGen (cc (FJust cA)) (genJust genA)- ]-- genEitherF ::- ( 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. EitherF ConcreteClassifier x y -> ConcreteClassifier (f x y))- -> (SizedGen a -> SizedGen (f a Void))- -> (SizedGen b -> SizedGen (f Void b))- -> ClassifiedGen a- -> ClassifiedGen b- -> Gen (Some ClassifiedGen)- genEitherF cc genLeft genRight (ClassifiedGen cA genA) (ClassifiedGen cB genB) =- elements [- Some $ ClassifiedGen (cc (FLeft cA)) (genLeft genA)- , Some $ ClassifiedGen (cc (FRight cB)) (genRight genB)- ]-- genMaybePairF ::- ( 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. MaybePairF ConcreteClassifier x y -> ConcreteClassifier (f x y))- -> Gen (f Void Void)- -> (SizedGen a -> SizedGen b -> SizedGen (f a b))- -> ClassifiedGen a -> ClassifiedGen b -> Gen (Some ClassifiedGen)- genMaybePairF cc genNothing genJust (ClassifiedGen cA genA) (ClassifiedGen cB genB) =- elements [- Some $ ClassifiedGen (cc FNothingPair) (ignoreSize $ genNothing)- , Some $ ClassifiedGen (cc (FJustPair cA cB)) (genJust genA genB)- ]-- genF ::- ( forall x. Show x => Show (f x)- , forall x. Eq x => Eq (f x)- )- => (forall x. ConcreteClassifier x -> ConcreteClassifier (f x))- -> (SizedGen a -> SizedGen (f a))- -> ClassifiedGen a -> Gen (Some ClassifiedGen)- genF cc gen (ClassifiedGen cA genA) = return $- Some $ ClassifiedGen (cc cA) (gen genA)- -- We check that we cover all cases of 'Classifier' rather than -- 'ConcreteClassifier': it is important that we generate test cases for -- everything we classify in the main library.@@ -450,17 +415,21 @@ -- Compound - C_Maybe{} -> ()- C_Either{} -> ()- C_List{} -> ()- C_Ratio{} -> ()- C_Set{} -> ()- C_Map{} -> ()- C_IntSet{} -> ()- C_IntMap{} -> ()- C_Tuple{} -> ()- C_Sequence{} -> ()- C_Tree{} -> ()+ C_Maybe{} -> ()+ C_Either{} -> ()+ C_List{} -> ()+ C_Ratio{} -> ()+ C_Set{} -> ()+ C_Map{} -> ()+ C_IntSet{} -> ()+ C_IntMap{} -> ()+ C_Tuple{} -> ()+ C_Sequence{} -> ()+ C_Tree{} -> ()+ C_HashSet{} -> ()+ C_HashMap{} -> ()+ C_HM_Array{} -> ()+ C_Vector_Boxed{} -> () -- Reference cells @@ -517,6 +486,77 @@ Some . Value cc <$> runSized sz gen {-------------------------------------------------------------------------------+ Helpers+-------------------------------------------------------------------------------}++genListLike :: ([a] -> x) -> SizedGen a -> SizedGen x+genListLike f gen = SizedGen $ \valSz -> do+ n <- choose (1, 5)+ f <$> vectorOf n (runSized (valSz `div` n) gen)++genMapLike :: ([(a, b)] -> x) -> SizedGen a -> SizedGen b -> SizedGen x+genMapLike f (SizedGen genX) (SizedGen genY) = SizedGen $ \valSz -> do+ n <- choose (1, 5)+ f <$> vectorOf n (+ (,) <$> genX (valSz `div` n `div` 2)+ <*> genY (valSz `div` n `div` 2)+ )++genMaybeF ::+ ( forall x. Show x => Show (f x)+ , forall x. Eq x => Eq (f x)+ )+ => (forall x. MaybeF ConcreteClassifier x -> ConcreteClassifier (f x))+ -> Gen (f Void)+ -> (SizedGen a -> SizedGen (f a))+ -> ClassifiedGen a -> Gen (Some ClassifiedGen)+genMaybeF cc genNothing genJust (ClassifiedGen cA genA) =+ elements [+ Some $ ClassifiedGen (cc FNothing) (ignoreSize $ genNothing)+ , Some $ ClassifiedGen (cc (FJust cA)) (genJust genA)+ ]++genEitherF ::+ ( 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. EitherF ConcreteClassifier x y -> ConcreteClassifier (f x y))+ -> (SizedGen a -> SizedGen (f a Void))+ -> (SizedGen b -> SizedGen (f Void b))+ -> ClassifiedGen a+ -> ClassifiedGen b+ -> Gen (Some ClassifiedGen)+genEitherF cc genLeft genRight (ClassifiedGen cA genA) (ClassifiedGen cB genB) =+ elements [+ Some $ ClassifiedGen (cc (FLeft cA)) (genLeft genA)+ , Some $ ClassifiedGen (cc (FRight cB)) (genRight genB)+ ]++genMaybePairF ::+ ( 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. MaybePairF ConcreteClassifier x y -> ConcreteClassifier (f x y))+ -> Gen (f Void Void)+ -> (SizedGen a -> SizedGen b -> SizedGen (f a b))+ -> ClassifiedGen a -> ClassifiedGen b -> Gen (Some ClassifiedGen)+genMaybePairF cc genNothing genJust (ClassifiedGen cA genA) (ClassifiedGen cB genB) =+ elements [+ Some $ ClassifiedGen (cc FNothingPair) (ignoreSize $ genNothing)+ , Some $ ClassifiedGen (cc (FJustPair cA cB)) (genJust genA genB)+ ]++genF ::+ ( forall x. Show x => Show (f x)+ , forall x. Eq x => Eq (f x)+ )+ => (forall x. ConcreteClassifier x -> ConcreteClassifier (f x))+ -> (SizedGen a -> SizedGen (f a))+ -> ClassifiedGen a -> Gen (Some ClassifiedGen)+genF cc gen (ClassifiedGen cA genA) = return $+ Some $ ClassifiedGen (cc cA) (gen genA)++{------------------------------------------------------------------------------- Auxiliary tree functions -------------------------------------------------------------------------------} @@ -564,7 +604,7 @@ recursive :: Int -> [Gen Aeson.Value] recursive sz = [ do n <- choose (0, 5)- Aeson.Array . Vector.fromList <$> replicateM n (go (sz `div` n))+ Aeson.Array . Vector.Boxed.fromList <$> replicateM n (go (sz `div` n)) , do n <- choose (0, 5) Aeson.object <$> replicateM n ( (Aeson..=)
tests/Test/RecoverRTTI/Classify.hs view
@@ -12,13 +12,17 @@ import Data.SOP import Data.Type.Equality -import qualified Data.Aeson as Aeson-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Map as Map-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Tree as Tree+import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Internal.Array as HashMap.Array+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Tree as Tree+import qualified Data.Vector as Vector.Boxed import Test.Tasty import Test.Tasty.QuickCheck hiding (classify, NonEmpty)@@ -123,6 +127,17 @@ , compareClassifier $ Value (CC_Tree CC_Int) (Tree.Node 1 []) + , compareClassifier $ Value (CC_HashSet CC_Int) (HashSet.fromList [1, 2, 3])++ , compareClassifier $ Value (CC_HashMap FNothingPair) HashMap.empty+ , compareClassifier $ Value (CC_HashMap (FJustPair CC_Int CC_Char)) (HashMap.fromList [(1, 'a'), (2, 'b')])++ , compareClassifier $ Value (CC_HM_Array FNothing) (HashMap.Array.fromList 0 [])+ , compareClassifier $ Value (CC_HM_Array (FJust CC_Int)) (HashMap.Array.fromList 2 [1, 2])++ , compareClassifier $ Value (CC_Vector_Boxed FNothing) Vector.Boxed.empty+ , compareClassifier $ Value (CC_Vector_Boxed (FJust CC_Int)) (Vector.Boxed.fromList [1, 2, 3])+ -- Reference cells , compareClassifier $ Value CC_STRef exampleIORef@@ -180,17 +195,21 @@ -- Compound - CC_Maybe{} -> ()- CC_Either{} -> ()- CC_List{} -> ()- CC_Ratio{} -> ()- CC_Set{} -> ()- CC_Map{} -> ()- CC_IntSet{} -> ()- CC_IntMap{} -> ()- CC_Sequence{} -> ()- CC_Tree{} -> ()- CC_Tuple{} -> ()+ CC_Maybe{} -> ()+ CC_Either{} -> ()+ CC_List{} -> ()+ CC_Ratio{} -> ()+ CC_Set{} -> ()+ CC_Map{} -> ()+ CC_IntSet{} -> ()+ CC_IntMap{} -> ()+ CC_Sequence{} -> ()+ CC_Tree{} -> ()+ CC_Tuple{} -> ()+ CC_HashSet{} -> ()+ CC_HashMap{} -> ()+ CC_HM_Array{} -> ()+ CC_Vector_Boxed{} -> () -- Functions
tests/Test/RecoverRTTI/ConcreteClassifier.hs view
@@ -18,6 +18,8 @@ , Value(..) ) where +import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet) import Data.Int import Data.IntMap (IntMap) import Data.IntSet (IntSet)@@ -32,12 +34,14 @@ import Data.Type.Equality import Data.Word -import qualified Data.Aeson as Aeson-import qualified Data.ByteString as BS.Strict-import qualified Data.ByteString.Lazy as BS.Lazy-import qualified Data.ByteString.Short as BS.Short-import qualified Data.Text as Text.Strict-import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS.Strict+import qualified Data.ByteString.Lazy as BS.Lazy+import qualified Data.ByteString.Short as BS.Short+import qualified Data.HashMap.Internal.Array as HashMap (Array)+import qualified Data.Text as Text.Strict+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Vector as Vector.Boxed import Debug.RecoverRTTI import Debug.RecoverRTTI.TypeLevel@@ -94,16 +98,20 @@ -- Compound - CC_Maybe :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Maybe a)- CC_Either :: EitherF ConcreteClassifier a b -> ConcreteClassifier (Either a b)- CC_List :: MaybeF ConcreteClassifier a -> ConcreteClassifier [a]- CC_Ratio :: ConcreteClassifier a -> ConcreteClassifier (Ratio a)- CC_Set :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Set a)- CC_Map :: MaybePairF ConcreteClassifier a b -> ConcreteClassifier (Map a b)- CC_IntSet :: ConcreteClassifier IntSet- CC_IntMap :: MaybeF ConcreteClassifier a -> ConcreteClassifier (IntMap a)- CC_Sequence :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Seq a)- CC_Tree :: ConcreteClassifier a -> ConcreteClassifier (Tree a)+ CC_Maybe :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Maybe a)+ CC_Either :: EitherF ConcreteClassifier a b -> ConcreteClassifier (Either a b)+ CC_List :: MaybeF ConcreteClassifier a -> ConcreteClassifier [a]+ CC_Ratio :: ConcreteClassifier a -> ConcreteClassifier (Ratio a)+ CC_Set :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Set a)+ CC_Map :: MaybePairF ConcreteClassifier a b -> ConcreteClassifier (Map a b)+ CC_IntSet :: ConcreteClassifier IntSet+ CC_IntMap :: MaybeF ConcreteClassifier a -> ConcreteClassifier (IntMap a)+ CC_Sequence :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Seq a)+ CC_Tree :: ConcreteClassifier a -> ConcreteClassifier (Tree a)+ CC_HashSet :: ConcreteClassifier a -> ConcreteClassifier (HashSet a)+ CC_HashMap :: MaybePairF ConcreteClassifier a b -> ConcreteClassifier (HashMap a b)+ CC_HM_Array :: MaybeF ConcreteClassifier a -> ConcreteClassifier (HashMap.Array a)+ CC_Vector_Boxed :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Vector.Boxed.Vector a) CC_Tuple :: (SListI xs, IsValidSize (Length xs))@@ -183,16 +191,20 @@ -- Compound - go (CC_Maybe c) = 1 + goMaybeF c- go (CC_Either c) = 1 + goEitherF c- go (CC_List c) = 1 + goMaybeF c- go (CC_Ratio c) = 1 + go c- go (CC_Set c) = 1 + goMaybeF c- go (CC_Map c) = 1 + goMaybePairF c- go CC_IntSet = 1- go (CC_IntMap c) = 1 + goMaybeF c- go (CC_Sequence c) = 1 + goMaybeF c- go (CC_Tree c) = 1 + go c+ go (CC_Maybe c) = 1 + goMaybeF c+ go (CC_Either c) = 1 + goEitherF c+ go (CC_List c) = 1 + goMaybeF c+ go (CC_Ratio c) = 1 + go c+ go (CC_Set c) = 1 + goMaybeF c+ go (CC_Map c) = 1 + goMaybePairF c+ go CC_IntSet = 1+ go (CC_IntMap c) = 1 + goMaybeF c+ go (CC_Sequence c) = 1 + goMaybeF c+ go (CC_Tree c) = 1 + go c+ go (CC_HashSet c) = 1 + go c+ go (CC_HashMap c) = 1 + goMaybePairF c+ go (CC_HM_Array c) = 1 + goMaybeF c+ go (CC_Vector_Boxed c) = 1 + goMaybeF c go (CC_Tuple (ConcreteClassifiers cs)) = 1 + sum (hcollapse (hmap (K . go) cs))@@ -286,16 +298,20 @@ -- Compound - go (CC_Maybe c) (CC_Maybe c') = goMaybeF c c'- go (CC_Either c) (CC_Either c') = goEitherF c c'- go (CC_List c) (CC_List c') = goMaybeF c c'- go (CC_Ratio c) (CC_Ratio c') = goF c c'- go (CC_Set c) (CC_Set c') = goMaybeF c c'- go (CC_Map c) (CC_Map c') = goMaybePairF c c'- go CC_IntSet CC_IntSet = Just Refl- go (CC_IntMap c) (CC_IntMap c') = goMaybeF c c'- go (CC_Sequence c) (CC_Sequence c') = goMaybeF c c'- go (CC_Tree c) (CC_Tree c') = goF c c'+ go (CC_Maybe c) (CC_Maybe c') = goMaybeF c c'+ go (CC_Either c) (CC_Either c') = goEitherF c c'+ go (CC_List c) (CC_List c') = goMaybeF c c'+ go (CC_Ratio c) (CC_Ratio c') = goF c c'+ go (CC_Set c) (CC_Set c') = goMaybeF c c'+ go (CC_Map c) (CC_Map c') = goMaybePairF c c'+ go CC_IntSet CC_IntSet = Just Refl+ go (CC_IntMap c) (CC_IntMap c') = goMaybeF c c'+ go (CC_Sequence c) (CC_Sequence c') = goMaybeF c c'+ go (CC_Tree c) (CC_Tree c') = goF c c'+ go (CC_HashSet c) (CC_HashSet c') = goF c c'+ go (CC_HashMap c) (CC_HashMap c') = goMaybePairF c c'+ go (CC_HM_Array c) (CC_HM_Array c') = goMaybeF c c'+ go (CC_Vector_Boxed c) (CC_Vector_Boxed c') = goMaybeF c c' go (CC_Tuple (ConcreteClassifiers cs)) (CC_Tuple (ConcreteClassifiers cs')) = (\Refl -> Refl) <$> goList cs cs'@@ -398,17 +414,21 @@ -- Compound - CC_Maybe{} -> ()- CC_Either{} -> ()- CC_List{} -> ()- CC_Ratio{} -> ()- CC_Set{} -> ()- CC_Map{} -> ()- CC_IntSet{} -> ()- CC_IntMap{} -> ()- CC_Tuple{} -> ()- CC_Sequence{} -> ()- CC_Tree{} -> ()+ CC_Maybe{} -> ()+ CC_Either{} -> ()+ CC_List{} -> ()+ CC_Ratio{} -> ()+ CC_Set{} -> ()+ CC_Map{} -> ()+ CC_IntSet{} -> ()+ CC_IntMap{} -> ()+ CC_Tuple{} -> ()+ CC_Sequence{} -> ()+ CC_Tree{} -> ()+ CC_HashSet{} -> ()+ CC_HashMap{} -> ()+ CC_HM_Array{} -> ()+ CC_Vector_Boxed{} -> () -- Reference cells
tests/Test/RecoverRTTI/Orphans.hs view
@@ -1,5 +1,10 @@ module Test.RecoverRTTI.Orphans () where +import Data.Function (on)++import qualified Data.HashMap.Internal.Array as HashMap (Array)+import qualified Data.HashMap.Internal.Array as HashMap.Array+ import Debug.RecoverRTTI -- | Degenerate 'Eq' instance for functions that always says 'True'@@ -12,3 +17,6 @@ -- library don't have acccess to this (misleading) instance. instance Eq SomeFun where _ == _ = True++instance Eq a => Eq (HashMap.Array a) where+ (==) = (==) `on` HashMap.Array.toList
tests/Test/RecoverRTTI/Staged.hs view
@@ -35,6 +35,8 @@ import Control.Monad.Except import Data.Bifunctor+import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet) import Data.Kind import Data.Map (Map) import Data.Set (Set)@@ -44,9 +46,12 @@ import GHC.Exts (Any) import GHC.Real import GHC.TypeLits+import Unsafe.Coerce (unsafeCoerce) -import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Data.HashMap.Internal.Array as HashMap (Array)+import qualified Data.HashMap.Internal.Array as HashMap.Array+import qualified Data.Map as Map+import qualified Data.Set as Set import Debug.RecoverRTTI import Debug.RecoverRTTI.TypeLevel@@ -126,16 +131,20 @@ -- Compound - C_Maybe c' -> goMaybeF fmap CC_Maybe c'- C_Either c' -> goEitherF bimap CC_Either c'- C_List c' -> goMaybeF fmap CC_List c'- C_Ratio c' -> goF coerceRatio CC_Ratio c'- C_Set c' -> goMaybeF coerceSet CC_Set c'- C_Map c' -> goMaybePairF coerceMap CC_Map c'- C_IntSet -> return $ Reclassified CC_IntSet id- C_IntMap c' -> goMaybeF fmap CC_IntMap c'- C_Sequence c' -> goMaybeF fmap CC_Sequence c'- C_Tree c' -> goF fmap CC_Tree c'+ C_Maybe c' -> goMaybeF fmap CC_Maybe c'+ C_Either c' -> goEitherF bimap CC_Either c'+ C_List c' -> goMaybeF fmap CC_List c'+ C_Ratio c' -> goF coerceRatio CC_Ratio c'+ C_Set c' -> goMaybeF coerceSet CC_Set c'+ C_Map c' -> goMaybePairF coerceMap CC_Map c'+ C_IntSet -> return $ Reclassified CC_IntSet id+ C_IntMap c' -> goMaybeF fmap CC_IntMap c'+ C_Sequence c' -> goMaybeF fmap CC_Sequence c'+ C_Tree c' -> goF fmap CC_Tree c'+ C_HashSet c' -> goF coerceHashSet CC_HashSet c'+ C_HashMap c' -> goMaybePairF coerceHashMap CC_HashMap c'+ C_HM_Array c' -> goMaybeF coerceHMArray CC_HM_Array c'+ C_Vector_Boxed c' -> goMaybeF fmap CC_Vector_Boxed c' C_Tuple (Classifiers cs) -> reclassifyTuple <$> (hsequence' (hmap (Comp . reclassify) cs))@@ -253,6 +262,18 @@ coerceMap :: (x -> x') -> (y -> y') -> Map x y -> Map x' y' coerceMap f g = Map.fromDistinctAscList . map (bimap f g) . Map.toAscList++coerceHMArray :: (x -> x') -> HashMap.Array x -> HashMap.Array x'+coerceHMArray f arr =+ let xs = HashMap.Array.toList arr+ in HashMap.Array.fromList (length xs) (map f xs)++-- Unfortunately, coercion on HashSet/HashMap is not expressible using its API+coerceHashSet :: (x -> x') -> HashSet x -> HashSet x'+coerceHashSet _ = unsafeCoerce++coerceHashMap :: (x -> x') -> (y -> y') -> HashMap x y -> HashMap x' y'+coerceHashMap _ _ = unsafeCoerce {------------------------------------------------------------------------------- When we reclassify values of user-defined types with type arguments, we need