module System.Vacuum.Ubigraph(view) where

import GHC.Vacuum
import Data.Char
import Text.Printf
import Data.List

import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet

import qualified Graphics.Ubigraph as U

nodeStyle n =
    case nodeName n of
      ":"  -> ("(:)", "cube", "#0000ff")

      k | k `elem` ["S#" ,"I#" ,"W#"
                   ,"I8#" ,"I16#" ,"I32#" ,"I64#"
                   ,"W8#" ,"W16#" ,"W32#" ,"W64#"] -> (showLit n, "sphere", "#00ff00")

      "C#" -> (show . chr . fromIntegral . head . nodeLits $ n, "sphere", "#00ff00")
      "D#" -> ("Double", "sphere", "#009900")
      "F#" -> ("Float", "sphere", "#009900")


      "PS"    -> (printf "ByteString[%d,%d]" (nodeLits n !! 1) (nodeLits n !! 2), "cube", "#ff0000")
      "Chunk" -> (printf "Chunk[%d,%d]" (nodeLits n !! 1) (nodeLits n !! 2), "cube", "#ff0000")

      c   | z > 0 ->
                    (c ++ show (take (fromIntegral z) $ nodeLits n), "cube", "#990000")
          | otherwise -> (c, "cube", "#990000")
                    where z = itabLits (nodeInfo n)
        where
          showLit n = show (head $ nodeLits n)

-- | Render a value using Ubigraph
view :: a -> IO ()
view a = do
  U.clear srv
  mapM_ renderNode nodes
  mapM_ renderEdge edges
    where      
      g = vacuum a
      alist = toAdjList g
      nodes = nub $ map fst alist ++ concatMap snd alist
      edges = concatMap (\(n, ns) -> map ((,) n) ns) alist

      style nid = maybe ("...", "cube", "#ff0000") nodeStyle (IntMap.lookup nid g)

      renderNode nid = do
           U.newVertexWithId srv nid
           let (label, shape, color) = style nid
           U.setVertexAttribute srv nid "label" label
           U.setVertexAttribute srv nid "shape" shape
           U.setVertexAttribute srv nid "color" color
      
      renderEdge (a, b) = do
           e <- U.newEdge srv a b
           U.setEdgeAttribute srv e "stroke" "dotted"
           U.setEdgeAttribute srv e "arrow" "true"

      srv = U.defaultServer