Create a gist now

Instantly share code, notes, and snippets.

@kowey /cmd
Created Jan 21, 2010

What would you like to do?
./heapgraph < example | dot -T pdf -o example.pdf
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"
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment