{-# LANGUAGE BangPatterns #-}

module Debug.RecoverRTTI.ClosureTree (
    showClosureTree
  ) where

import Data.List
import GHC.Exts.Heap

-- | Show closure tree up to the given depth
--
-- Used only for internal debugging
showClosureTree :: Int -> a -> IO String
showClosureTree :: Int -> a -> IO String
showClosureTree = \Int
d -> Int -> Int -> Box -> IO String
go Int
d Int
0 (Box -> IO String) -> (a -> Box) -> a -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Box
forall a. a -> Box
asBox
  where
    go :: Int -> Int -> Box -> IO String
    go :: Int -> Int -> Box -> IO String
go Int
0 Int
_ Box
_ = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    go Int
d Int
i Box
x = do
        Closure
closure <- Box -> IO Closure
getBoxedClosureData Box
x
        Closure -> [String] -> String
render Closure
closure ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Box -> IO String) -> [Box] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Int -> Box -> IO String
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) (Closure -> [Box]
forall b. GenClosure b -> [b]
allClosures Closure
closure)
      where
        render :: Closure -> [String] -> String
        render :: Closure -> [String] -> String
render Closure
closure [String]
nested = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
              (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ Closure -> String
forall a. Show a => a -> String
show Closure
closure)
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
nested