cap-1.0: src/Language/Cap/Debug/Dotty.hs

module Language.Cap.Debug.Dotty (pretty) where

import Language.Cap.Debug.Trace

import Data.List (isSuffixOf,sortBy)


-- | Takes a trace graph and outputs a ``dot'' representation of it
pretty :: Graph -> String
pretty g =
  "digraph Trace {\nordering=out;\n" ++
  concatMap (makeRankGroup . (concatMap (prettyNode g))) (groupNodes (allNodes g)) ++ concatMap (prettyEdges g) (allNodes g) ++ " } "

groupNodes :: [NodeName] -> [[NodeName]]
groupNodes xs =
  groupNodes' $ reverse $ sortBy compareNumberOfRs xs
  where
    groupNodes' :: [NodeName] -> [[NodeName]]
    groupNodes' [] = []
    groupNodes' (x:xs) = (allRedexes x):(groupNodes' (filter (notResOf x) xs))
    
    notResOf :: NodeName -> NodeName -> Bool
    notResOf ('r':x) y = x /= y && notResOf x y
    notResOf _ _ = True
    
    allRedexes ('r':xs) = ('r':xs) : allRedexes xs
    allRedexes x = [x]

compareNumberOfRs x y = compare (numRs x) (numRs y)

numRs :: String -> Int
numRs ('r':xs) = 1 + numRs xs
numRs _ = 0

makeRankGroup n = " { rank = same;\n" ++ n ++ " }\n"

prettyNode :: Graph -> NodeName -> String
prettyNode g x =
  case nodeValue g x of
    Just (Atom a)
      -> (nodeName x) ++ " [label=\"" ++ a ++ "\"];\n"
    Just (Application i j)
      -> (nodeName x) ++ " [label=\"\"];\n"
    Just (Indirection i)
      -> (nodeName x) ++ " [label=\"\"];\n"

prettyEdges :: Graph -> NodeName -> String
prettyEdges g x =
  (case nodeValue g x of
     Just (Atom a)
       -> ""
     Just (Application i j)
       -> (nodeName x) ++ " -> " ++ (nodeName i) ++ ";\n" ++
          (nodeName x) ++ " -> " ++ (nodeName j) ++ ";\n"
     Just (Indirection i)
       -> (nodeName x) ++ " -> " ++ (nodeName i) ++ ";\n")
  ++ (case x of
        ('r':y) -> (nodeName y) ++ " -> " ++ x ++ " [style = bold];\n"
        _       -> "")


nodeName :: String -> String
nodeName "" = "m"
nodeName x = x