{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE NamedFieldPuns #-}
module GHC.Debug.Types.Graph( -- * Types
                              HeapGraph(..)
                            , HeapGraphEntry(..)
                            , HeapGraphIndex
                            , PapHI
                            , StackHI
                            , SrtHI
                            -- * Building a heap graph
                            , DerefFunction
                            , buildHeapGraph
                            , multiBuildHeapGraph
                            , generalBuildHeapGraph

                            -- * Printing a heap graph
                            , ppHeapGraph
                            , ppClosure

                            -- * Utility
                            , lookupHeapGraph
                            , traverseHeapGraph
                            , updateHeapGraph
                            , heapGraphSize
                            , annotateHeapGraph

                            -- * Reverse Graph
                            , ReverseGraph
                            , mkReverseGraph
                            , reverseEdges
                            )
                            where

import Data.Char
import Data.List (intercalate, foldl', sort, group, sortBy, groupBy)
import Data.Maybe       ( catMaybes )
import Data.Function
import qualified Data.HashMap.Strict as M
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import GHC.Debug.Types.Ptr
import GHC.Debug.Types.Closures
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
import Data.Bitraversable

-- | For heap graphs, i.e. data structures that also represent sharing and
-- cyclic structures, these are the entries. If the referenced value is
-- @Nothing@, then we do not have that value in the map, most likely due to
-- exceeding the recursion bound passed to 'buildHeapGraph'.
--
-- Besides a pointer to the stored value and the closure representation we
-- have a slot for arbitrary data, for the user's convenience.
data HeapGraphEntry a = HeapGraphEntry {
        forall a. HeapGraphEntry a -> ClosurePtr
hgeClosurePtr :: ClosurePtr,
        forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure :: DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe HeapGraphIndex),
        forall a. HeapGraphEntry a -> a
hgeData :: a}
    deriving (Int -> HeapGraphEntry a -> ShowS
[HeapGraphEntry a] -> ShowS
HeapGraphEntry a -> String
(Int -> HeapGraphEntry a -> ShowS)
-> (HeapGraphEntry a -> String)
-> ([HeapGraphEntry a] -> ShowS)
-> Show (HeapGraphEntry a)
forall a. Show a => Int -> HeapGraphEntry a -> ShowS
forall a. Show a => [HeapGraphEntry a] -> ShowS
forall a. Show a => HeapGraphEntry a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> HeapGraphEntry a -> ShowS
showsPrec :: Int -> HeapGraphEntry a -> ShowS
$cshow :: forall a. Show a => HeapGraphEntry a -> String
show :: HeapGraphEntry a -> String
$cshowList :: forall a. Show a => [HeapGraphEntry a] -> ShowS
showList :: [HeapGraphEntry a] -> ShowS
Show, (forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b)
-> (forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a)
-> Functor HeapGraphEntry
forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
fmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
$c<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
Functor, (forall m. Monoid m => HeapGraphEntry m -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m)
-> (forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b)
-> (forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b)
-> (forall a. (a -> a -> a) -> HeapGraphEntry a -> a)
-> (forall a. (a -> a -> a) -> HeapGraphEntry a -> a)
-> (forall a. HeapGraphEntry a -> [a])
-> (forall a. HeapGraphEntry a -> Bool)
-> (forall a. HeapGraphEntry a -> Int)
-> (forall a. Eq a => a -> HeapGraphEntry a -> Bool)
-> (forall a. Ord a => HeapGraphEntry a -> a)
-> (forall a. Ord a => HeapGraphEntry a -> a)
-> (forall a. Num a => HeapGraphEntry a -> a)
-> (forall a. Num a => HeapGraphEntry a -> a)
-> Foldable HeapGraphEntry
forall a. Eq a => a -> HeapGraphEntry a -> Bool
forall a. Num a => HeapGraphEntry a -> a
forall a. Ord a => HeapGraphEntry a -> a
forall m. Monoid m => HeapGraphEntry m -> m
forall a. HeapGraphEntry a -> Bool
forall a. HeapGraphEntry a -> Int
forall a. HeapGraphEntry a -> [a]
forall a. (a -> a -> a) -> HeapGraphEntry a -> a
forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => HeapGraphEntry m -> m
fold :: forall m. Monoid m => HeapGraphEntry m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
foldr :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
foldl :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
foldr1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
foldl1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
$ctoList :: forall a. HeapGraphEntry a -> [a]
toList :: forall a. HeapGraphEntry a -> [a]
$cnull :: forall a. HeapGraphEntry a -> Bool
null :: forall a. HeapGraphEntry a -> Bool
$clength :: forall a. HeapGraphEntry a -> Int
length :: forall a. HeapGraphEntry a -> Int
$celem :: forall a. Eq a => a -> HeapGraphEntry a -> Bool
elem :: forall a. Eq a => a -> HeapGraphEntry a -> Bool
$cmaximum :: forall a. Ord a => HeapGraphEntry a -> a
maximum :: forall a. Ord a => HeapGraphEntry a -> a
$cminimum :: forall a. Ord a => HeapGraphEntry a -> a
minimum :: forall a. Ord a => HeapGraphEntry a -> a
$csum :: forall a. Num a => HeapGraphEntry a -> a
sum :: forall a. Num a => HeapGraphEntry a -> a
$cproduct :: forall a. Num a => HeapGraphEntry a -> a
product :: forall a. Num a => HeapGraphEntry a -> a
Foldable, Functor HeapGraphEntry
Foldable HeapGraphEntry
(Functor HeapGraphEntry, Foldable HeapGraphEntry) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    HeapGraphEntry (f a) -> f (HeapGraphEntry a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b))
-> (forall (m :: * -> *) a.
    Monad m =>
    HeapGraphEntry (m a) -> m (HeapGraphEntry a))
-> Traversable HeapGraphEntry
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
sequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
Traversable)
type HeapGraphIndex = ClosurePtr

type StackHI = GenStackFrames (GenSrtPayload (Maybe HeapGraphIndex)) (Maybe HeapGraphIndex)
type PapHI =  GenPapPayload (Maybe HeapGraphIndex)
type SrtHI =  GenSrtPayload (Maybe HeapGraphIndex)

-- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
-- as the internal representation may change. Nevertheless, we export it here:
-- Sometimes the user knows better what he needs than we do.
data HeapGraph a = HeapGraph
                      { forall a. HeapGraph a -> NonEmpty ClosurePtr
roots :: !(NE.NonEmpty ClosurePtr)
                      , forall a. HeapGraph a -> IntMap (HeapGraphEntry a)
graph :: !(IM.IntMap (HeapGraphEntry a)) }
    deriving (Int -> HeapGraph a -> ShowS
[HeapGraph a] -> ShowS
HeapGraph a -> String
(Int -> HeapGraph a -> ShowS)
-> (HeapGraph a -> String)
-> ([HeapGraph a] -> ShowS)
-> Show (HeapGraph a)
forall a. Show a => Int -> HeapGraph a -> ShowS
forall a. Show a => [HeapGraph a] -> ShowS
forall a. Show a => HeapGraph a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> HeapGraph a -> ShowS
showsPrec :: Int -> HeapGraph a -> ShowS
$cshow :: forall a. Show a => HeapGraph a -> String
show :: HeapGraph a -> String
$cshowList :: forall a. Show a => [HeapGraph a] -> ShowS
showList :: [HeapGraph a] -> ShowS
Show, (forall m. Monoid m => HeapGraph m -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraph a -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraph a -> m)
-> (forall a b. (a -> b -> b) -> b -> HeapGraph a -> b)
-> (forall a b. (a -> b -> b) -> b -> HeapGraph a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraph a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraph a -> b)
-> (forall a. (a -> a -> a) -> HeapGraph a -> a)
-> (forall a. (a -> a -> a) -> HeapGraph a -> a)
-> (forall a. HeapGraph a -> [a])
-> (forall a. HeapGraph a -> Bool)
-> (forall a. HeapGraph a -> Int)
-> (forall a. Eq a => a -> HeapGraph a -> Bool)
-> (forall a. Ord a => HeapGraph a -> a)
-> (forall a. Ord a => HeapGraph a -> a)
-> (forall a. Num a => HeapGraph a -> a)
-> (forall a. Num a => HeapGraph a -> a)
-> Foldable HeapGraph
forall a. Eq a => a -> HeapGraph a -> Bool
forall a. Num a => HeapGraph a -> a
forall a. Ord a => HeapGraph a -> a
forall m. Monoid m => HeapGraph m -> m
forall a. HeapGraph a -> Bool
forall a. HeapGraph a -> Int
forall a. HeapGraph a -> [a]
forall a. (a -> a -> a) -> HeapGraph a -> a
forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => HeapGraph m -> m
fold :: forall m. Monoid m => HeapGraph m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
foldr :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
foldl :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
foldr1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
foldl1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
$ctoList :: forall a. HeapGraph a -> [a]
toList :: forall a. HeapGraph a -> [a]
$cnull :: forall a. HeapGraph a -> Bool
null :: forall a. HeapGraph a -> Bool
$clength :: forall a. HeapGraph a -> Int
length :: forall a. HeapGraph a -> Int
$celem :: forall a. Eq a => a -> HeapGraph a -> Bool
elem :: forall a. Eq a => a -> HeapGraph a -> Bool
$cmaximum :: forall a. Ord a => HeapGraph a -> a
maximum :: forall a. Ord a => HeapGraph a -> a
$cminimum :: forall a. Ord a => HeapGraph a -> a
minimum :: forall a. Ord a => HeapGraph a -> a
$csum :: forall a. Num a => HeapGraph a -> a
sum :: forall a. Num a => HeapGraph a -> a
$cproduct :: forall a. Num a => HeapGraph a -> a
product :: forall a. Num a => HeapGraph a -> a
Foldable, Functor HeapGraph
Foldable HeapGraph
(Functor HeapGraph, Foldable HeapGraph) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> HeapGraph a -> f (HeapGraph b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    HeapGraph (f a) -> f (HeapGraph a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> HeapGraph a -> m (HeapGraph b))
-> (forall (m :: * -> *) a.
    Monad m =>
    HeapGraph (m a) -> m (HeapGraph a))
-> Traversable HeapGraph
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraph a -> f (HeapGraph b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraph a -> f (HeapGraph b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraph a -> f (HeapGraph b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
sequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
Traversable, (forall a b. (a -> b) -> HeapGraph a -> HeapGraph b)
-> (forall a b. a -> HeapGraph b -> HeapGraph a)
-> Functor HeapGraph
forall a b. a -> HeapGraph b -> HeapGraph a
forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
fmap :: forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
$c<$ :: forall a b. a -> HeapGraph b -> HeapGraph a
<$ :: forall a b. a -> HeapGraph b -> HeapGraph a
Functor)

traverseHeapGraph :: Applicative m =>
                    (HeapGraphEntry a -> m (HeapGraphEntry b))
                  -> HeapGraph a
                  -> m (HeapGraph b)
traverseHeapGraph :: forall (m :: * -> *) a b.
Applicative m =>
(HeapGraphEntry a -> m (HeapGraphEntry b))
-> HeapGraph a -> m (HeapGraph b)
traverseHeapGraph HeapGraphEntry a -> m (HeapGraphEntry b)
f (HeapGraph NonEmpty ClosurePtr
r IntMap (HeapGraphEntry a)
im) = NonEmpty ClosurePtr -> IntMap (HeapGraphEntry b) -> HeapGraph b
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r (IntMap (HeapGraphEntry b) -> HeapGraph b)
-> m (IntMap (HeapGraphEntry b)) -> m (HeapGraph b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HeapGraphEntry a -> m (HeapGraphEntry b))
-> IntMap (HeapGraphEntry a) -> m (IntMap (HeapGraphEntry b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntMap a -> f (IntMap b)
traverse HeapGraphEntry a -> m (HeapGraphEntry b)
f IntMap (HeapGraphEntry a)
im


lookupHeapGraph :: HeapGraphIndex -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph :: forall a. ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph (ClosurePtr Word64
i) (HeapGraph NonEmpty ClosurePtr
_r IntMap (HeapGraphEntry a)
m) = Int -> IntMap (HeapGraphEntry a) -> Maybe (HeapGraphEntry a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) IntMap (HeapGraphEntry a)
m

insertHeapGraph :: HeapGraphIndex -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
insertHeapGraph :: forall a.
ClosurePtr -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
insertHeapGraph (ClosurePtr Word64
i) HeapGraphEntry a
a (HeapGraph NonEmpty ClosurePtr
r IntMap (HeapGraphEntry a)
m) = NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r (Int
-> HeapGraphEntry a
-> IntMap (HeapGraphEntry a)
-> IntMap (HeapGraphEntry a)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) HeapGraphEntry a
a IntMap (HeapGraphEntry a)
m)

updateHeapGraph :: (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
                -> HeapGraphIndex
                -> HeapGraph a
                -> HeapGraph a
updateHeapGraph :: forall a.
(HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> ClosurePtr -> HeapGraph a -> HeapGraph a
updateHeapGraph HeapGraphEntry a -> Maybe (HeapGraphEntry a)
f (ClosurePtr Word64
i) (HeapGraph NonEmpty ClosurePtr
r IntMap (HeapGraphEntry a)
m) = NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r ((HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> Int -> IntMap (HeapGraphEntry a) -> IntMap (HeapGraphEntry a)
forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.update HeapGraphEntry a -> Maybe (HeapGraphEntry a)
f (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) IntMap (HeapGraphEntry a)
m)

heapGraphSize :: HeapGraph a -> Int
heapGraphSize :: forall a. HeapGraph a -> Int
heapGraphSize (HeapGraph NonEmpty ClosurePtr
_ IntMap (HeapGraphEntry a)
g) = IntMap (HeapGraphEntry a) -> Int
forall a. IntMap a -> Int
IM.size IntMap (HeapGraphEntry a)
g

-- | Creates a 'HeapGraph' for the value in the box, but not recursing further
-- than the given limit.
buildHeapGraph
   :: (MonadFix m)
   => DerefFunction m a
   -> Maybe Int
   -> ClosurePtr -- ^ The value to start with
   -> m (HeapGraph a)
buildHeapGraph :: forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a -> Maybe Int -> ClosurePtr -> m (HeapGraph a)
buildHeapGraph DerefFunction m a
deref Maybe Int
limit ClosurePtr
initialBox =
  DerefFunction m a
-> Maybe Int -> NonEmpty ClosurePtr -> m (HeapGraph a)
forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int -> NonEmpty ClosurePtr -> m (HeapGraph a)
multiBuildHeapGraph DerefFunction m a
deref Maybe Int
limit (ClosurePtr -> NonEmpty ClosurePtr
forall a. a -> NonEmpty a
NE.singleton ClosurePtr
initialBox)

-- TODO: It is a bit undesirable that the ConstrDesc field is already
-- dereferenced, but also, not such a big deal. It could lead to additional
-- requests to the debuggee which are not necessary and causes a mismatch
-- with the step-by-step decoding functions in `Client.hs`
type DerefFunction m a = ClosurePtr -> m (DebugClosureWithExtra a SrtPayload PapPayload ConstrDesc (GenStackFrames SrtPayload ClosurePtr) ClosurePtr)

-- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
--   further than the given limit.
multiBuildHeapGraph
    :: (MonadFix m)
    => DerefFunction m a
    -> Maybe Int
    -> NonEmpty ClosurePtr -- ^ Starting values with associated data entry
    -> m (HeapGraph a)
multiBuildHeapGraph :: forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int -> NonEmpty ClosurePtr -> m (HeapGraph a)
multiBuildHeapGraph DerefFunction m a
deref Maybe Int
limit NonEmpty ClosurePtr
rs =
  DerefFunction m a
-> Maybe Int
-> HeapGraph a
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int
-> HeapGraph a
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
generalBuildHeapGraph DerefFunction m a
deref Maybe Int
limit (NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
rs IntMap (HeapGraphEntry a)
forall a. IntMap a
IM.empty) NonEmpty ClosurePtr
rs
{-# INLINE multiBuildHeapGraph #-}

-- | Adds the given annotation to the entry at the given index, using the
-- 'mappend' operation of its 'Monoid' instance.
annotateHeapGraph ::  (a -> a) -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
annotateHeapGraph :: forall a. (a -> a) -> ClosurePtr -> HeapGraph a -> HeapGraph a
annotateHeapGraph a -> a
f ClosurePtr
i HeapGraph a
hg = (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> ClosurePtr -> HeapGraph a -> HeapGraph a
forall a.
(HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> ClosurePtr -> HeapGraph a -> HeapGraph a
updateHeapGraph HeapGraphEntry a -> Maybe (HeapGraphEntry a)
go ClosurePtr
i HeapGraph a
hg
  where
    go :: HeapGraphEntry a -> Maybe (HeapGraphEntry a)
go HeapGraphEntry a
hge = HeapGraphEntry a -> Maybe (HeapGraphEntry a)
forall a. a -> Maybe a
Just (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> HeapGraphEntry a -> Maybe (HeapGraphEntry a)
forall a b. (a -> b) -> a -> b
$ HeapGraphEntry a
hge { hgeData = f (hgeData hge) }

{-# INLINE generalBuildHeapGraph #-}
generalBuildHeapGraph
    :: forall m a .  (MonadFix m)
    => DerefFunction m a
    -> Maybe Int
    -> HeapGraph a
    -> NonEmpty ClosurePtr
    -> m (HeapGraph a)
generalBuildHeapGraph :: forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int
-> HeapGraph a
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
generalBuildHeapGraph DerefFunction m a
deref Maybe Int
limit HeapGraph a
hg NonEmpty ClosurePtr
addBoxes = do
    -- First collect all boxes from the existing heap graph
    (NonEmpty (Maybe ClosurePtr)
_is, HeapGraph a
hg') <- StateT (HeapGraph a) m (NonEmpty (Maybe ClosurePtr))
-> HeapGraph a -> m (NonEmpty (Maybe ClosurePtr), HeapGraph a)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> NonEmpty ClosurePtr
-> StateT (HeapGraph a) m (NonEmpty (Maybe ClosurePtr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Maybe Int
-> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add Maybe Int
limit) NonEmpty ClosurePtr
addBoxes) HeapGraph a
hg
    HeapGraph a -> m (HeapGraph a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return HeapGraph a
hg'
  where
    add :: Maybe Int -> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
    add :: Maybe Int
-> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add (Just Int
0) ClosurePtr
_ = Maybe ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
forall a. a -> StateT (HeapGraph a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ClosurePtr
forall a. Maybe a
Nothing
    add Maybe Int
n ClosurePtr
cp = do
        -- If the box is in the map, return the index
        HeapGraph a
hm <- StateT (HeapGraph a) m (HeapGraph a)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
forall a. ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph ClosurePtr
cp HeapGraph a
hm of
            Just {} -> Maybe ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
forall a. a -> StateT (HeapGraph a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosurePtr -> Maybe ClosurePtr
forall a. a -> Maybe a
Just ClosurePtr
cp)
            -- FIXME GHC BUG: change `mdo` to `do` below:
            --       "GHC internal error: ‘c’ is not in scope during type checking, but it passed the renamer"
            Maybe (HeapGraphEntry a)
Nothing -> mdo
                -- Look up the closure
                DebugClosureWithExtra
  a
  SrtPayload
  PapPayload
  ConstrDesc
  (GenStackFrames SrtPayload ClosurePtr)
  ClosurePtr
c <- m (DebugClosureWithExtra
     a
     SrtPayload
     PapPayload
     ConstrDesc
     (GenStackFrames SrtPayload ClosurePtr)
     ClosurePtr)
-> StateT
     (HeapGraph a)
     m
     (DebugClosureWithExtra
        a
        SrtPayload
        PapPayload
        ConstrDesc
        (GenStackFrames SrtPayload ClosurePtr)
        ClosurePtr)
forall (m :: * -> *) a. Monad m => m a -> StateT (HeapGraph a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (DebugClosureWithExtra
      a
      SrtPayload
      PapPayload
      ConstrDesc
      (GenStackFrames SrtPayload ClosurePtr)
      ClosurePtr)
 -> StateT
      (HeapGraph a)
      m
      (DebugClosureWithExtra
         a
         SrtPayload
         PapPayload
         ConstrDesc
         (GenStackFrames SrtPayload ClosurePtr)
         ClosurePtr))
-> m (DebugClosureWithExtra
        a
        SrtPayload
        PapPayload
        ConstrDesc
        (GenStackFrames SrtPayload ClosurePtr)
        ClosurePtr)
-> StateT
     (HeapGraph a)
     m
     (DebugClosureWithExtra
        a
        SrtPayload
        PapPayload
        ConstrDesc
        (GenStackFrames SrtPayload ClosurePtr)
        ClosurePtr)
forall a b. (a -> b) -> a -> b
$ DerefFunction m a
deref ClosurePtr
cp
                let new_add :: ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add = Maybe Int
-> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
n)
                -- NOTE: We tie-the-knot here with RecursiveDo so that we don't
                -- get into an infinite loop with cycles in the heap.
                rec (HeapGraph a -> HeapGraph a) -> StateT (HeapGraph a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (ClosurePtr -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
forall a.
ClosurePtr -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
insertHeapGraph ClosurePtr
cp (ClosurePtr
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> a
-> HeapGraphEntry a
forall a.
ClosurePtr
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> a
-> HeapGraphEntry a
HeapGraphEntry ClosurePtr
cp DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' a
e))
                    -- Add the resulting closure below to the map (above):
                    DCS a
e DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' <- (SrtPayload -> StateT (HeapGraph a) m SrtHI)
-> (PapPayload -> StateT (HeapGraph a) m PapHI)
-> (ConstrDesc -> StateT (HeapGraph a) m ConstrDesc)
-> (GenStackFrames SrtPayload ClosurePtr
    -> StateT (HeapGraph a) m StackHI)
-> (ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> DebugClosureWithExtra
     a
     SrtPayload
     PapPayload
     ConstrDesc
     (GenStackFrames SrtPayload ClosurePtr)
     ClosurePtr
-> StateT
     (HeapGraph a)
     m
     (DebugClosureWithExtra
        a SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra a a c e h j
-> f (DebugClosureWithExtra a b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
       h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> SrtPayload -> StateT (HeapGraph a) m SrtHI
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenSrtPayload a -> f (GenSrtPayload b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> PapPayload -> StateT (HeapGraph a) m PapHI
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenPapPayload a -> f (GenPapPayload b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ConstrDesc -> StateT (HeapGraph a) m ConstrDesc
forall a. a -> StateT (HeapGraph a) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SrtPayload -> StateT (HeapGraph a) m SrtHI)
-> (ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> GenStackFrames SrtPayload ClosurePtr
-> StateT (HeapGraph a) m StackHI
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d) -> GenStackFrames a b -> f (GenStackFrames c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> SrtPayload -> StateT (HeapGraph a) m SrtHI
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenSrtPayload a -> f (GenSrtPayload b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add DebugClosureWithExtra
  a
  SrtPayload
  PapPayload
  ConstrDesc
  (GenStackFrames SrtPayload ClosurePtr)
  ClosurePtr
c
                Maybe ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
forall a. a -> StateT (HeapGraph a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosurePtr -> Maybe ClosurePtr
forall a. a -> Maybe a
Just ClosurePtr
cp)

-- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
-- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
--
-- >let x1 = "Ki"
-- >    x6 = C# 'H' : C# 'o' : x6
-- >in (x1,x1,x6)
ppHeapGraph :: (a -> String) -> HeapGraph a -> String
ppHeapGraph :: forall a. (a -> String) -> HeapGraph a -> String
ppHeapGraph a -> String
printData (HeapGraph (ClosurePtr
heapGraphRoot :| [ClosurePtr]
rs) IntMap (HeapGraphEntry a)
m) = String
letWrapper String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
printData (HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
heapGraphRoot)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
roots
  where
    -- All variables occuring more than once
    bindings :: [ClosurePtr]
bindings = HeapGraph a -> [ClosurePtr] -> [ClosurePtr]
forall a. HeapGraph a -> [ClosurePtr] -> [ClosurePtr]
boundMultipleTimes (NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph (ClosurePtr
heapGraphRoot ClosurePtr -> [ClosurePtr] -> NonEmpty ClosurePtr
forall a. a -> [a] -> NonEmpty a
:| [ClosurePtr]
rs) IntMap (HeapGraphEntry a)
m) [ClosurePtr
heapGraphRoot]

    roots :: String
roots = [String] -> String
unlines [
              String
"r" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
printData (HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
r)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Maybe ClosurePtr -> String
ppRef Int
0 (ClosurePtr -> Maybe ClosurePtr
forall a. a -> Maybe a
Just ClosurePtr
r) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
              | (Int
n, ClosurePtr
r) <- [Int] -> [ClosurePtr] -> [(Int, ClosurePtr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (ClosurePtr
heapGraphRoot ClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
: [ClosurePtr]
rs) ]

    letWrapper :: String
letWrapper =
        if [ClosurePtr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClosurePtr]
bindings
        then String
""
        else String
"let " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n    " ((ClosurePtr -> String) -> [ClosurePtr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ClosurePtr -> String
ppBinding [ClosurePtr]
bindings) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nin "

    bindingLetter :: ClosurePtr -> Char
bindingLetter ClosurePtr
i = case HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i) of
        ThunkClosure {} -> Char
't'
        SelectorClosure {} -> Char
't'
        APClosure {} -> Char
't'
        PAPClosure {} -> Char
'f'
        BCOClosure {} -> Char
't'
        FunClosure {} -> Char
'f'
        DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
_ -> Char
'x'

    ppBindingMap :: HashMap ClosurePtr String
ppBindingMap = [(ClosurePtr, String)] -> HashMap ClosurePtr String
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(ClosurePtr, String)] -> HashMap ClosurePtr String)
-> [(ClosurePtr, String)] -> HashMap ClosurePtr String
forall a b. (a -> b) -> a -> b
$
        ([(ClosurePtr, Char)] -> [(ClosurePtr, String)])
-> [[(ClosurePtr, Char)]] -> [(ClosurePtr, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Int -> (ClosurePtr, Char) -> (ClosurePtr, String))
-> [Int] -> [(ClosurePtr, Char)] -> [(ClosurePtr, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
j (ClosurePtr
i,Char
c) -> (ClosurePtr
i, Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
j)) [(Int
1::Int)..]) ([[(ClosurePtr, Char)]] -> [(ClosurePtr, String)])
-> [[(ClosurePtr, Char)]] -> [(ClosurePtr, String)]
forall a b. (a -> b) -> a -> b
$
        ((ClosurePtr, Char) -> (ClosurePtr, Char) -> Bool)
-> [(ClosurePtr, Char)] -> [[(ClosurePtr, Char)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Char -> Char -> Bool)
-> ((ClosurePtr, Char) -> Char)
-> (ClosurePtr, Char)
-> (ClosurePtr, Char)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ClosurePtr, Char) -> Char
forall a b. (a, b) -> b
snd) ([(ClosurePtr, Char)] -> [[(ClosurePtr, Char)]])
-> [(ClosurePtr, Char)] -> [[(ClosurePtr, Char)]]
forall a b. (a -> b) -> a -> b
$
        ((ClosurePtr, Char) -> (ClosurePtr, Char) -> Ordering)
-> [(ClosurePtr, Char)] -> [(ClosurePtr, Char)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Char -> Char -> Ordering)
-> ((ClosurePtr, Char) -> Char)
-> (ClosurePtr, Char)
-> (ClosurePtr, Char)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ClosurePtr, Char) -> Char
forall a b. (a, b) -> b
snd)
        [ (ClosurePtr
i, ClosurePtr -> Char
bindingLetter ClosurePtr
i) | ClosurePtr
i <- [ClosurePtr]
bindings ]

    ppVar :: ClosurePtr -> String
ppVar ClosurePtr
i = HashMap ClosurePtr String
ppBindingMap HashMap ClosurePtr String -> ClosurePtr -> String
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! ClosurePtr
i
    ppBinding :: ClosurePtr -> String
ppBinding ClosurePtr
i = ClosurePtr -> String
ppVar ClosurePtr
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
printData (HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i)) String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
") = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> HeapGraphEntry a -> String
ppEntry Int
0 (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i)

    ppEntry :: Int -> HeapGraphEntry a -> String
ppEntry Int
prec HeapGraphEntry a
hge
        | Just String
s <- DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe String
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr) -> Maybe String
isString (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge) = ShowS
forall a. Show a => a -> String
show String
s
        | Just [Maybe ClosurePtr]
l <- DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge)   = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((Maybe ClosurePtr -> String) -> [Maybe ClosurePtr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe ClosurePtr -> String
ppRef Int
0) [Maybe ClosurePtr]
l) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
        | Bool
otherwise = (Int -> Maybe ClosurePtr -> String)
-> Int
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> String
forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure Int -> Maybe ClosurePtr -> String
ppRef Int
prec (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge)
      where
        _app :: [String] -> String
_app [String
a] = String
a  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"()"
        _app [String]
xs = Bool -> ShowS
addBraces (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([String] -> String
unwords [String]
xs)

    ppRef :: Int -> Maybe ClosurePtr -> String
ppRef Int
_ Maybe ClosurePtr
Nothing = String
"..."
    ppRef Int
prec (Just ClosurePtr
i) | ClosurePtr
i ClosurePtr -> [ClosurePtr] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ClosurePtr]
bindings = ClosurePtr -> String
ppVar ClosurePtr
i
                        | Bool
otherwise = Int -> HeapGraphEntry a -> String
ppEntry Int
prec (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i)
    iToE :: ClosurePtr -> HeapGraphEntry a
iToE (ClosurePtr Word64
i) = IntMap (HeapGraphEntry a)
m IntMap (HeapGraphEntry a) -> Int -> HeapGraphEntry a
forall a. IntMap a -> Int -> a
IM.! (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)

    iToUnboundE :: ClosurePtr -> Maybe (HeapGraphEntry a)
iToUnboundE cp :: ClosurePtr
cp@(ClosurePtr Word64
i)
        | ClosurePtr
cp ClosurePtr -> [ClosurePtr] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ClosurePtr]
bindings = Maybe (HeapGraphEntry a)
forall a. Maybe a
Nothing
        | Bool
otherwise         = Int -> IntMap (HeapGraphEntry a) -> Maybe (HeapGraphEntry a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) IntMap (HeapGraphEntry a)
m

    isList :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex]
    isList :: forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
c
        | DebugClosure srt p ConstrDesc s (Maybe ClosurePtr) -> Bool
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Bool
isNil DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
c =
            [Maybe ClosurePtr] -> Maybe [Maybe ClosurePtr]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        | Bool
otherwise = do
            (Maybe ClosurePtr
h,Maybe ClosurePtr
t) <- DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe (Maybe ClosurePtr, Maybe ClosurePtr)
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
c
            ClosurePtr
ti <- Maybe ClosurePtr
t
            HeapGraphEntry a
e <- ClosurePtr -> Maybe (HeapGraphEntry a)
iToUnboundE ClosurePtr
ti
            [Maybe ClosurePtr]
t' <- DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
e)
            return $ (:) Maybe ClosurePtr
h [Maybe ClosurePtr]
t'

    isString :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe String
    isString :: forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr) -> Maybe String
isString DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
e = do
        [Maybe ClosurePtr]
list <- DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
e
        -- We do not want to print empty lists as "" as we do not know that they
        -- are really strings.
        if [Maybe ClosurePtr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe ClosurePtr]
list
        then Maybe String
forall a. Maybe a
Nothing
        else (Maybe ClosurePtr -> Maybe Char)
-> [Maybe ClosurePtr] -> Maybe String
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe Char
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar (DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
 -> Maybe Char)
-> (HeapGraphEntry a
    -> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
-> HeapGraphEntry a
-> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure (HeapGraphEntry a -> Maybe Char)
-> (Maybe ClosurePtr -> Maybe (HeapGraphEntry a))
-> Maybe ClosurePtr
-> Maybe Char
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ClosurePtr -> Maybe (HeapGraphEntry a)
iToUnboundE (ClosurePtr -> Maybe (HeapGraphEntry a))
-> (Maybe ClosurePtr -> Maybe ClosurePtr)
-> Maybe ClosurePtr
-> Maybe (HeapGraphEntry a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe ClosurePtr -> Maybe ClosurePtr
forall a. a -> a
id) [Maybe ClosurePtr]
list


-- | In the given HeapMap, list all indices that are used more than once. The
-- second parameter adds external references, commonly @[heapGraphRoot]@.
boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
boundMultipleTimes :: forall a. HeapGraph a -> [ClosurePtr] -> [ClosurePtr]
boundMultipleTimes (HeapGraph NonEmpty ClosurePtr
_rs IntMap (HeapGraphEntry a)
m) [ClosurePtr]
roots = ([ClosurePtr] -> ClosurePtr) -> [[ClosurePtr]] -> [ClosurePtr]
forall a b. (a -> b) -> [a] -> [b]
map [ClosurePtr] -> ClosurePtr
forall a. HasCallStack => [a] -> a
head ([[ClosurePtr]] -> [ClosurePtr]) -> [[ClosurePtr]] -> [ClosurePtr]
forall a b. (a -> b) -> a -> b
$ ([ClosurePtr] -> Bool) -> [[ClosurePtr]] -> [[ClosurePtr]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> ([ClosurePtr] -> Bool) -> [ClosurePtr] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[ClosurePtr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[ClosurePtr]] -> [[ClosurePtr]])
-> [[ClosurePtr]] -> [[ClosurePtr]]
forall a b. (a -> b) -> a -> b
$ [ClosurePtr] -> [[ClosurePtr]]
forall a. Eq a => [a] -> [[a]]
group ([ClosurePtr] -> [[ClosurePtr]]) -> [ClosurePtr] -> [[ClosurePtr]]
forall a b. (a -> b) -> a -> b
$ [ClosurePtr] -> [ClosurePtr]
forall a. Ord a => [a] -> [a]
sort ([ClosurePtr] -> [ClosurePtr]) -> [ClosurePtr] -> [ClosurePtr]
forall a b. (a -> b) -> a -> b
$
     [ClosurePtr]
roots [ClosurePtr] -> [ClosurePtr] -> [ClosurePtr]
forall a. [a] -> [a] -> [a]
++ (HeapGraphEntry a -> [ClosurePtr])
-> [HeapGraphEntry a] -> [ClosurePtr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Maybe ClosurePtr] -> [ClosurePtr]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ClosurePtr] -> [ClosurePtr])
-> (HeapGraphEntry a -> [Maybe ClosurePtr])
-> HeapGraphEntry a
-> [ClosurePtr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> [Maybe ClosurePtr]
forall c a.
DebugClosure
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
 -> [Maybe ClosurePtr])
-> (HeapGraphEntry a
    -> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
-> HeapGraphEntry a
-> [Maybe ClosurePtr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure) (IntMap (HeapGraphEntry a) -> [HeapGraphEntry a]
forall a. IntMap a -> [a]
IM.elems IntMap (HeapGraphEntry a)
m)

-- Utilities

addBraces :: Bool -> String -> String
addBraces :: Bool -> ShowS
addBraces Bool
True String
t = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
addBraces Bool
False String
t = String
t

braceize :: [String] -> String
braceize :: [String] -> String
braceize [] = String
""
braceize [String]
xs = String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"

isChar :: DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar ConstrClosure{ constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc {pkg :: ConstrDesc -> String
pkg = String
"ghc-prim", modl :: ConstrDesc -> String
modl = String
"GHC.Types", name :: ConstrDesc -> String
name = String
"C#"}, dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [Word
ch], ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
ptrArgs = []} = Char -> Maybe Char
forall a. a -> Maybe a
Just (Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
ch))
isChar DebugClosure srt p ConstrDesc s c
_ = Maybe Char
forall a. Maybe a
Nothing

isNil :: DebugClosure srt p ConstrDesc s c -> Bool
isNil :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Bool
isNil ConstrClosure{ constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc {pkg :: ConstrDesc -> String
pkg = String
"ghc-prim", modl :: ConstrDesc -> String
modl = String
"GHC.Types", name :: ConstrDesc -> String
name = String
"[]"}, dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [Word]
_, ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
ptrArgs = []} = Bool
True
isNil DebugClosure srt p ConstrDesc s c
_ = Bool
False

isCons :: DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons ConstrClosure{ constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc {pkg :: ConstrDesc -> String
pkg = String
"ghc-prim", modl :: ConstrDesc -> String
modl = String
"GHC.Types", name :: ConstrDesc -> String
name = String
":"}, dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [], ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
ptrArgs = [c
h,c
t]} = (c, c) -> Maybe (c, c)
forall a. a -> Maybe a
Just (c
h,c
t)
isCons DebugClosure srt p ConstrDesc s c
_ = Maybe (c, c)
forall a. Maybe a
Nothing

isTup :: DebugClosure srt p ConstrDesc s c -> Maybe [c]
isTup :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe [c]
isTup ConstrClosure{ dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [], [c]
ConstrDesc
StgInfoTableWithPtr
constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: StgInfoTableWithPtr
ptrArgs :: [c]
constrDesc :: ConstrDesc
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} =
    if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstrDesc -> String
name ConstrDesc
constrDesc) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&&
       String -> Char
forall a. HasCallStack => [a] -> a
head (ConstrDesc -> String
name ConstrDesc
constrDesc) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& String -> Char
forall a. HasCallStack => [a] -> a
last (ConstrDesc -> String
name ConstrDesc
constrDesc) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&&
       (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (ShowS
forall a. HasCallStack => [a] -> [a]
tail (ShowS
forall a. HasCallStack => [a] -> [a]
init (ConstrDesc -> String
name ConstrDesc
constrDesc)))
    then [c] -> Maybe [c]
forall a. a -> Maybe a
Just [c]
ptrArgs else Maybe [c]
forall a. Maybe a
Nothing
isTup DebugClosure srt p ConstrDesc s c
_ = Maybe [c]
forall a. Maybe a
Nothing



-- | A pretty-printer that tries to generate valid Haskell for evalutated data.
-- It assumes that for the included boxes, you already replaced them by Strings
-- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
--
-- The parameter gives the precedendence, to avoid avoidable parenthesises.
ppClosure :: (Int -> c -> String) -> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure :: forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure Int -> c -> String
showBox Int
prec DebugClosure (GenSrtPayload c) p ConstrDesc s c
c = case DebugClosure (GenSrtPayload c) p ConstrDesc s c
c of
    DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just Char
ch <- DebugClosure (GenSrtPayload c) p ConstrDesc s c -> Maybe Char
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar DebugClosure (GenSrtPayload c) p ConstrDesc s c
c -> [String] -> String
app
        [String
"C#", Char -> String
forall a. Show a => a -> String
show Char
ch]
    DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just (c
h,c
t) <- DebugClosure (GenSrtPayload c) p ConstrDesc s c -> Maybe (c, c)
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure (GenSrtPayload c) p ConstrDesc s c
c -> Bool -> ShowS
addBraces (Int
5 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        Int -> c -> String
showBox Int
5 c
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> c -> String
showBox Int
4 c
t
    DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just [c]
vs <- DebugClosure (GenSrtPayload c) p ConstrDesc s c -> Maybe [c]
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe [c]
isTup DebugClosure (GenSrtPayload c) p ConstrDesc s c
c ->
        String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
0) [c]
vs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    ConstrClosure {[c]
[Word]
ConstrDesc
StgInfoTableWithPtr
constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
ptrArgs :: [c]
dataArgs :: [Word]
constrDesc :: ConstrDesc
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        ConstrDesc -> String
name ConstrDesc
constrDesc String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
ptrArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Word -> String) -> [Word] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word -> String
forall a. Show a => a -> String
show [Word]
dataArgs
    ThunkClosure {[c]
[Word]
GenSrtPayload c
StgInfoTableWithPtr
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
srt :: GenSrtPayload c
ptrArgs :: [c]
dataArgs :: [Word]
srt :: forall srt pap string s b. DebugClosure srt pap string s b -> srt
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        let srt_string :: [String]
srt_string = case GenSrtPayload c -> Maybe c
forall b. GenSrtPayload b -> Maybe b
getSrt GenSrtPayload c
srt of
                            Maybe c
Nothing -> []
                            Just c
s  -> [String
"{", Int -> c -> String
showBox Int
10 c
s, String
"}"]
        in [String
"_thunk" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
srt_string] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
ptrArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Word -> String) -> [Word] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word -> String
forall a. Show a => a -> String
show [Word]
dataArgs

    SelectorClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
selectee :: c
selectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
        [String
"_sel", Int -> c -> String
showBox Int
10 c
selectee]
    IndClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
indirectee :: c
indirectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
        [String
"_ind", Int -> c -> String
showBox Int
10 c
indirectee]
    BlackholeClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
indirectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
info :: StgInfoTableWithPtr
indirectee :: c
..} -> [String] -> String
app
        [String
"_bh",  Int -> c -> String
showBox Int
10 c
indirectee]
    APClosure {c
p
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
arity :: Word32
n_args :: Word32
fun :: c
ap_payload :: p
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
n_args :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
ap_payload :: forall srt pap string s b. DebugClosure srt pap string s b -> pap
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) ([c] -> [String]) -> [c] -> [String]
forall a b. (a -> b) -> a -> b
$
        [c
fun]
        -- TODO: Payload
    PAPClosure {c
p
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
n_args :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
info :: StgInfoTableWithPtr
arity :: Word32
n_args :: Word32
fun :: c
pap_payload :: p
pap_payload :: forall srt pap string s b. DebugClosure srt pap string s b -> pap
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) ([c] -> [String]) -> [c] -> [String]
forall a b. (a -> b) -> a -> b
$
        [c
fun] -- TODO payload
    APStackClosure {c
s
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
info :: StgInfoTableWithPtr
ap_st_size :: Word
fun :: c
payload :: s
ap_st_size :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
payload :: forall srt pap string s b. DebugClosure srt pap string s b -> s
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) ([c] -> [String]) -> [c] -> [String]
forall a b. (a -> b) -> a -> b
$
        [c
fun] -- TODO: stack
    TRecChunkClosure {} -> String
"_trecChunk" --TODO
    BCOClosure {c
[Word]
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
info :: StgInfoTableWithPtr
instrs :: c
literals :: c
bcoptrs :: c
arity :: Word32
size :: Word32
bitmap :: [Word]
instrs :: forall srt pap string s b. DebugClosure srt pap string s b -> b
literals :: forall srt pap string s b. DebugClosure srt pap string s b -> b
bcoptrs :: forall srt pap string s b. DebugClosure srt pap string s b -> b
size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
bitmap :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
..} -> [String] -> String
app
        [String
"_bco", Int -> c -> String
showBox Int
10 c
bcoptrs]
    ArrWordsClosure {[Word]
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
bytes :: Word
arrWords :: [Word]
bytes :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
arrWords :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
..} -> [String] -> String
app
        [String
"ARR_WORDS", String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++Word -> String
forall a. Show a => a -> String
show Word
bytes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes)", ((ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [Word] -> ByteString
arrWordsBS [Word]
arrWords)) ]
    MutArrClosure {[c]
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
mccPtrs :: Word
mccSize :: Word
mccPayload :: [c]
mccPtrs :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccSize :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccPayload :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
..} -> [String] -> String
app
        --["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
        [String
"[", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
shorten ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
mccPayload)),String
"]"]
    SmallMutArrClosure {[c]
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
mccPtrs :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccPayload :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: StgInfoTableWithPtr
mccPtrs :: Word
mccPayload :: [c]
..} -> [String] -> String
app
        [String
"[", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
shorten ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
mccPayload)),String
"]"]
    MutVarClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
var :: c
var :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
        [String
"_mutVar", Int -> c -> String
showBox Int
10 c
var]
    MVarClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
queueHead :: c
queueTail :: c
value :: c
queueHead :: forall srt pap string s b. DebugClosure srt pap string s b -> b
queueTail :: forall srt pap string s b. DebugClosure srt pap string s b -> b
value :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
        [String
"MVar", Int -> c -> String
showBox Int
10 c
value]
    FunClosure {[c]
[Word]
GenSrtPayload c
StgInfoTableWithPtr
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
srt :: forall srt pap string s b. DebugClosure srt pap string s b -> srt
info :: StgInfoTableWithPtr
srt :: GenSrtPayload c
ptrArgs :: [c]
dataArgs :: [Word]
..} ->
        let srt_string :: [String]
srt_string = case GenSrtPayload c -> Maybe c
forall b. GenSrtPayload b -> Maybe b
getSrt GenSrtPayload c
srt of
                            Maybe c
Nothing -> []
                            Just c
s  -> [String
"{", Int -> c -> String
showBox Int
10 c
s, String
"}"]
        in String
"_fun" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([String] -> String
unwords [String]
srt_string) String -> ShowS
forall a. [a] -> [a] -> [a]
++  [String] -> String
braceize ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
0) [c]
ptrArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Word -> String) -> [Word] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word -> String
forall a. Show a => a -> String
show [Word]
dataArgs)
    BlockingQueueClosure {} ->
        String
"_blockingQueue"
    OtherClosure {} ->
        String
"_other"
    TSOClosure {c
Int64
[TsoFlags]
Maybe c
Maybe StgTSOProfInfo
Word32
Word64
WhyBlocked
WhatNext
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
_link :: c
global_link :: c
tsoStack :: c
trec :: c
blocked_exceptions :: c
bq :: c
threadLabel :: Maybe c
what_next :: WhatNext
why_blocked :: WhyBlocked
flags :: [TsoFlags]
threadId :: Word64
saved_errno :: Word32
dirty :: Word32
alloc_limit :: Int64
tot_stack_size :: Word32
prof :: Maybe StgTSOProfInfo
_link :: forall srt pap string s b. DebugClosure srt pap string s b -> b
global_link :: forall srt pap string s b. DebugClosure srt pap string s b -> b
tsoStack :: forall srt pap string s b. DebugClosure srt pap string s b -> b
trec :: forall srt pap string s b. DebugClosure srt pap string s b -> b
blocked_exceptions :: forall srt pap string s b. DebugClosure srt pap string s b -> b
bq :: forall srt pap string s b. DebugClosure srt pap string s b -> b
threadLabel :: forall srt pap string s b.
DebugClosure srt pap string s b -> Maybe b
what_next :: forall srt pap string s b.
DebugClosure srt pap string s b -> WhatNext
why_blocked :: forall srt pap string s b.
DebugClosure srt pap string s b -> WhyBlocked
flags :: forall srt pap string s b.
DebugClosure srt pap string s b -> [TsoFlags]
threadId :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word64
saved_errno :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
dirty :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
alloc_limit :: forall srt pap string s b. DebugClosure srt pap string s b -> Int64
tot_stack_size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
prof :: forall srt pap string s b.
DebugClosure srt pap string s b -> Maybe StgTSOProfInfo
..} -> String
"TSO: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ WhyBlocked -> String
forall a. Show a => a -> String
show WhyBlocked
why_blocked
    StackClosure {s
Word8
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
stack_size :: Word32
stack_dirty :: Word8
stack_marking :: Word8
frames :: s
stack_size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
stack_dirty :: forall srt pap string s b. DebugClosure srt pap string s b -> Word8
stack_marking :: forall srt pap string s b. DebugClosure srt pap string s b -> Word8
frames :: forall srt pap string s b. DebugClosure srt pap string s b -> s
..} -> [String] -> String
app [String
"Stack(", Word32 -> String
forall a. Show a => a -> String
show Word32
stack_size, String
")"] -- TODO
    WeakClosure {} -> String
"_wk" -- TODO
    TVarClosure {} -> String
"_tvar" -- TODO
    MutPrimClosure {} -> String
"_mutPrim" -- TODO
    UnsupportedClosure {StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
info} -> (StgInfoTableWithPtr -> String
forall a. Show a => a -> String
show StgInfoTableWithPtr
info)


  where
    app :: [String] -> String
app [String
a] = String
a  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"()"
    app [String]
xs = Bool -> ShowS
addBraces (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([String] -> String
unwords [String]
xs)

    shorten :: [String] -> [String]
shorten [String]
xs = if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20 then Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
20 [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"(and more)"] else [String]
xs


-- Reverse Edges
--
closurePtrToInt :: ClosurePtr -> Int
closurePtrToInt :: ClosurePtr -> Int
closurePtrToInt (ClosurePtr Word64
p) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p

intToClosurePtr :: Int -> ClosurePtr
intToClosurePtr :: Int -> ClosurePtr
intToClosurePtr Int
i = Word64 -> ClosurePtr
mkClosurePtr (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

newtype ReverseGraph = ReverseGraph (IM.IntMap IS.IntSet)

reverseEdges :: ClosurePtr -> ReverseGraph -> Maybe [ClosurePtr]
reverseEdges :: ClosurePtr -> ReverseGraph -> Maybe [ClosurePtr]
reverseEdges ClosurePtr
cp (ReverseGraph IntMap IntSet
rg) =
  (Int -> ClosurePtr) -> [Int] -> [ClosurePtr]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ClosurePtr
intToClosurePtr ([Int] -> [ClosurePtr])
-> (IntSet -> [Int]) -> IntSet -> [ClosurePtr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList (IntSet -> [ClosurePtr]) -> Maybe IntSet -> Maybe [ClosurePtr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup (ClosurePtr -> Int
closurePtrToInt ClosurePtr
cp) IntMap IntSet
rg

mkReverseGraph :: HeapGraph a -> ReverseGraph
mkReverseGraph :: forall a. HeapGraph a -> ReverseGraph
mkReverseGraph (HeapGraph NonEmpty ClosurePtr
_ IntMap (HeapGraphEntry a)
hg) = IntMap IntSet -> ReverseGraph
ReverseGraph IntMap IntSet
graph
  where
    graph :: IntMap IntSet
graph = (IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet)
-> IntMap IntSet -> IntMap (HeapGraphEntry a) -> IntMap IntSet
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
forall {a}.
IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
collectNodes IntMap IntSet
forall a. IntMap a
IM.empty IntMap (HeapGraphEntry a)
hg
    collectNodes :: IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
collectNodes IntMap IntSet
newMap Int
k HeapGraphEntry a
h =
      let bs :: [Maybe ClosurePtr]
bs = DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> [Maybe ClosurePtr]
forall c a.
DebugClosure
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
h)
      in (IntMap IntSet -> Maybe ClosurePtr -> IntMap IntSet)
-> IntMap IntSet -> [Maybe ClosurePtr] -> IntMap IntSet
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap IntSet
m Maybe ClosurePtr
ma ->
                    case Maybe ClosurePtr
ma of
                      Maybe ClosurePtr
Nothing -> IntMap IntSet
m
                      Just ClosurePtr
a -> (IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union (ClosurePtr -> Int
closurePtrToInt ClosurePtr
a) (Int -> IntSet
IS.singleton Int
k) IntMap IntSet
m) IntMap IntSet
newMap [Maybe ClosurePtr]
bs