module System.Vacuum.Ubigraph (
Options(..),
hubigraphView,
defaultNodeStyle,
defaultEdgeStyle,
defaultExternNodeStyle,
defaultOptions,
defaultServer,
customView,
view
) where
import Graphics.Ubigraph
import GHC.Vacuum
import Data.Char
import Text.Printf
import Data.List
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
data Options = Options
{ nodeStyle :: HNode -> [VAttr],
edgeStyle :: Maybe HNode -> Maybe HNode -> [EAttr],
externNodeStyle :: [VAttr]
}
hubigraphView :: a -> Options -> Hubigraph ()
hubigraphView a options =
do clear
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
lookupNode n = IntMap.lookup n g
renderNode nid = do
newVertexWithID nid
mapM_ (flip setVAttr nid) $ maybe (externNodeStyle options) (nodeStyle options) (lookupNode nid)
renderEdge (a, b) = do
eid <- newEdge (a, b)
mapM_ (flip setEAttr eid) (edgeStyle options (lookupNode a) (lookupNode b))
defaultNodeStyle :: HNode -> [VAttr]
defaultNodeStyle n =
case nodeName n of
":" ->
[VLabel "(:)", VShape Cube, VColor "#0000ff"]
k | k `elem` ["S#" ,"I#" ,"W#"
,"I8#" ,"I16#" ,"I32#" ,"I64#"
,"W8#" ,"W16#" ,"W32#" ,"W64#"] ->
[VLabel (showLit n), VShape Sphere, VColor "#00ff00"]
"C#" ->
[VLabel $ show . chr . fromIntegral . head . nodeLits $ n,
VShape Sphere,
VColor "#00ff00"]
"D#" ->
[VLabel "Double", VShape Sphere, VColor "#009900"]
"F#" ->
[VLabel "Float", VShape Sphere, VColor "#009900"]
"PS" ->
[VLabel $ printf "ByteString[%d,%d]" (nodeLits n !! 1) (nodeLits n !! 2),
VShape Cube,
VColor "#ff0000"]
"Chunk" ->
[VLabel $ printf "Chunk[%d,%d]" (nodeLits n !! 1) (nodeLits n !! 2),
VShape Cube,
VColor "#ff0000"]
c
| z > 0 ->
[VLabel $ c ++ show (take (fromIntegral z) $ nodeLits n),
VShape Cube,
VColor "#990000"]
| otherwise ->
[VLabel c, VShape Cube,VColor "#990000"]
where
showLit n = show (head $ nodeLits n)
z = itabLits (nodeInfo n)
defaultEdgeStyle :: Maybe HNode -> Maybe HNode -> [EAttr]
defaultEdgeStyle _ _ = [EStroke Dotted, EArrow True]
defaultExternNodeStyle = [VShape Cube, VColor "#ff0000"]
defaultOptions = Options {
nodeStyle = defaultNodeStyle,
edgeStyle = defaultEdgeStyle,
externNodeStyle = defaultExternNodeStyle
}
defaultServer = "http://127.0.0.1:20738/RPC2"
customView :: Options -> String -> a -> IO ()
customView options server a = runHubigraph (hubigraphView a options) (Ubigraph server)
view :: a -> IO ()
view = customView defaultOptions defaultServer