cmd

./heapgraph < example | dot -T pdf -o example.pdf

example

graph g0
node n0 (closure "double" (closure "(*)" "5" "4"))

graph g1
node n0 (closure "(+)" n1 n1)
node n1 (closure "(*)" "5" "4")

graph g2
node n0 (closure "(+)" n1 n1)
node n1 "20"

graph g3
node n0 "40"

heapgraph.hs

{-# LANGUAGE FlexibleInstances #-}

import Control.Monad
import Data.List
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Language
import Text.ParserCombinators.Parsec.Token (TokenParser, LanguageDef(..), makeTokenParser)
import qualified Text.ParserCombinators.Parsec.Token as P

-- ----------------------------------------------------------------------
-- heap graph representation for graphviz
-- ----------------------------------------------------------------------

type Id = String
data Content p = Closure [p]
                | Value String
 deriving Show
data Node p = Node Id (Content p) deriving Show
data HG = HG Id [ Node Id ] deriving Show

toGraphviz (HG name xs) = unlines $ ("subgraph cluster_" ++ name ++ " {")
                                  : map toGraphvizI xs
                                  ++ [ "color=lightgrey", "};"]
toGraphvizI (Node i contents) =
 case contents of
   Value s    -> i ++ " [ shape=none label=\"" ++ s ++ "\"];"
   Closure ps -> toGraphvizClosure i ps

toGraphvizClosure i ps =
  unlines (node : zipWith mkLink pids ps)
 where
  node   =  i ++ " [ shape=record label=\"" ++ cells ++ "\"];"
  cells  = intercalate "|" $ zipWith mkCell pids ps
  pids   = [0..]
  mkCell p _ = "<f" ++ show p ++ ">"
  mkLink p x = concat [ i, ":f", show p, " -> ", x, ";" ]

-- ----------------------------------------------------------------------
-- heap graph representation for people (more convenient)
-- ----------------------------------------------------------------------

data Pointer = Explicit Id
             | Implicit (Content Pointer)
 deriving Show

data EzHG = EzHG Id [ Node Pointer ]
 deriving Show

-- | we assume that you never have "x" in your node names
mkHG :: EzHG -> HG
mkHG (EzHG name xs) = HG name (concatMap helper xs)
 where
  helper (Node x (Value s)) = [ Node x (Value s) ]
  helper (Node x (Closure ps)) = Node x (Closure ps2) : nodes
    where
     pids   = map (\y -> x ++ "x" ++ show y) $ take (length ps) [0..]
     --
     ps2    = zipWith toId pids ps
     toId _ (Explicit i) = i
     toId p (Implicit _) = p
     --
     nodes = concat $ zipWith mkNodes pids ps
     mkNodes _ (Explicit i) = []
     mkNodes p (Implicit c) = helper (Node p c)

mkEzHG n xs = EzHG n (map (appendName n) xs)

-- ----------------------------------------------------------------------
-- parser for ad-hoc heap graph language
-- ----------------------------------------------------------------------

hgLanguageDef :: LanguageDef ()
hgLanguageDef = emptyDef { reservedNames = [ "graph", "node", "closure" ] }

lexer :: TokenParser ()
lexer  = makeTokenParser hgLanguageDef

whiteSpace :: CharParser () ()
whiteSpace = P.whiteSpace lexer

identifier    = P.identifier lexer
stringLiteral = P.stringLiteral lexer
reserved      = P.reserved lexer
parens        = P.parens lexer

parseGraph =
 do reserved "graph"
    n <- identifier
    mkEzHG n `liftM` many parseNode

parseGraphs = many parseGraph

parseNode =
 do reserved "node"
    i <- identifier
    c <- parseContent
    return (Node i c)

parsePointer = parens helper <|> helper
 where
  helper = Explicit `liftM` identifier <|> Implicit `liftM` parseContent

parseContent = parens helper <|> helper
 where
  helper =
        do { reserved "closure"; Closure `liftM` (many parsePointer) }
    <|> do { Value `liftM` stringLiteral }

-- ----------------------------------------------------------------------
-- main
-- ----------------------------------------------------------------------

class AppendName a where
 appendName :: String -> a -> a

instance AppendName Pointer where
  appendName suf (Explicit x) = Explicit (x ++ suf)
  appendName suf (Implicit c) = Implicit (appendName suf c)

instance AppendName (Content Pointer) where
  appendName suf (Value x) = Value x
  appendName suf (Closure ps) = Closure (map (appendName suf) ps)

instance AppendName (Node Pointer) where
  appendName suf (Node x c) = Node (x ++ suf) (appendName suf c)

graph xs =
 unlines $ "digraph {" : map (toGraphviz . mkHG) xs ++ [ "}" ]

main =
 do c <- getContents
    let mp = parse parseGraphs "" c
    case mp of
      Left err -> fail $ show err
      Right ps -> putStr . graph $ ps