diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) 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.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 diff --git a/src/Debug/RecoverRTTI.hs b/src/Debug/RecoverRTTI.hs --- a/src/Debug/RecoverRTTI.hs +++ b/src/Debug/RecoverRTTI.hs @@ -26,7 +26,7 @@ , Some(..) -- ** Constructor information , Constr(..) - -- ** Type-level constructor informatino + -- ** Type-level constructor information , ConstrPkg , ConstrModl , ConstrName 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 @@ -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)) 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 @@ -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 diff --git a/src/Debug/RecoverRTTI/ClosureTree.hs b/src/Debug/RecoverRTTI/ClosureTree.hs --- a/src/Debug/RecoverRTTI/ClosureTree.hs +++ b/src/Debug/RecoverRTTI/ClosureTree.hs @@ -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 diff --git a/src/Debug/RecoverRTTI/Modules.hs b/src/Debug/RecoverRTTI/Modules.hs --- a/src/Debug/RecoverRTTI/Modules.hs +++ b/src/Debug/RecoverRTTI/Modules.hs @@ -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" diff --git a/tests/Test/RecoverRTTI/Arbitrary.hs b/tests/Test/RecoverRTTI/Arbitrary.hs --- a/tests/Test/RecoverRTTI/Arbitrary.hs +++ b/tests/Test/RecoverRTTI/Arbitrary.hs @@ -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..=) 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 @@ -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 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 @@ -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 diff --git a/tests/Test/RecoverRTTI/Orphans.hs b/tests/Test/RecoverRTTI/Orphans.hs --- a/tests/Test/RecoverRTTI/Orphans.hs +++ b/tests/Test/RecoverRTTI/Orphans.hs @@ -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 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 @@ -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