-- -- | -- Module : System.Vacuum.Cairo -- Copyright : (c) Tim Docker 2006, Don Stewart 2009 -- License : BSD-style -- -- Interactively visualize Haskell heap values as SVG graphs in a Cairo canvas -- using graphviz. -- -- > view [1..10] -- -- Will display a pop-up window of the data structure produced -- module System.Vacuum.Cairo ( view , viewFile -- export to .svg file ) where import qualified Graphics.UI.Gtk as G import qualified Graphics.UI.Gtk.Gdk.Events as G import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.SVG as C import qualified Graphics.UI.Gtk.Gdk.DrawWindow as G import qualified Graphics.UI.Gtk.Gdk.Gdk as G import GHC.Vacuum import Text.PrettyPrint import Text.Printf import Data.List import System.Process import Control.Concurrent (forkIO,yield) import System.IO import Control.Monad import System.Exit import Data.Char import qualified Control.Exception as C import System.Directory import Control.Concurrent.MVar.Strict import System.IO.Unsafe import Control.Parallel.Strategies ------------------------------------------------------------------------ data Session = Session { sWindow :: !G.Window , sDrawing :: !G.DrawingArea , sSVG :: !C.SVG } instance NFData Session where rnf x = x `seq` () sessionRef = unsafePerformIO $ newEmptyMVar {-# NOINLINE sessionRef #-} -- | Create a new vacuum session newSession :: IO () newSession = do G.unsafeInitGUIForThreadedRTS window <- G.windowNew canvas <- G.drawingAreaNew svg <- C.svgNewFromString welcome G.onKeyPress window $ anyKey (G.widgetDestroy window) G.onDestroy window (takeMVar sessionRef >> G.mainQuit) G.onExposeRect canvas $ const $ do -- print "EXPOSE" withMVar sessionRef $ \(Session _ c svg) -> updateCanvas svg c return () -- not needed. G.onExposeRect window $ const $ do -- print "EXPOSE" withMVar sessionRef $ \(Session _ c svg) -> updateCanvas svg c return () G.set window [G.containerChild G.:= canvas] G.windowSetDefaultSize window 400 200 G.widgetShowAll window forkIO G.mainGUI let s = Session { sWindow = window, sDrawing = canvas, sSVG = svg } putMVar sessionRef $! s ------------------------------------------------ -- | Set the style myPpDot :: [(String, [String])] -> Doc myPpDot = graphToDot id -- | . graphToDot :: (a -> String) -> [(a, [a])] -> Doc graphToDot f = ppGraph . fmap (f *** fmap f) where f *** g = \(a, b)->(f a, g b) ------------------------------------------------ -- | Graph style gStyle :: String gStyle = unlines [ -- "graph [concentrate=true];" "node [fontcolor=\"#1f33b3\", fontsize=12, shape=none, fontname=\"Helvetica\"];" ,"edge [color=\"#000000\", style=dotted, fontname=\"Helvetica\", arrowhead=normal, arrowsize=0.3];" ] ppGraph :: [(String, [String])] -> Doc ppGraph xs = (text "digraph g" <+> text "{") $+$ text gStyle $+$ nest indent (vcat . fmap ppEdge $ xs) $+$ text "}" where indent = 4 ppEdge :: (String, [String]) -> Doc ppEdge (x,xs) = -- label node (dQText x) <+> brackets (text "label=" <> dQText (takeWhile (/= '|') x)) $$ -- node data (dQText x) <+> (text "->") <+> (braces . hcat . punctuate comma . fmap dQText $ xs) dQText :: String -> Doc dQText = doubleQuotes . text ------------------------------------------------------------------------ -- Display node data. Everything before the | will be used as a label. myStyle = ShowHNode { showHNode = renderNode ,externHNode = \_ -> "..." } where renderNode i n = node ++ "|" ++ show i -- unique id -- some kinda atomic types: where node = case nodeName n of ":" -> "(:)" -- atomic stuff is special k | k `elem` ["S#" ,"I#" ,"W#" ,"I8#" ,"I16#" ,"I32#" ,"I64#" ,"W8#" ,"W16#" ,"W32#" ,"W64#"] -> showLit n -- chars "C#" -> show . chr . fromIntegral . head . nodeLits $ n "D#" -> "Double" "F#" -> "Float" -- bytestrings "PS" -> printf "ByteString[%d,%d]" (nodeLits n !! 1) (nodeLits n !! 2) "Chunk" -> printf "Chunk[%d,%d]" (nodeLits n !! 1) (nodeLits n !! 2) -- otherwise just the constructor and local fields c | z > 0 -> c ++ show (take (fromIntegral z) $ nodeLits n) | otherwise -> c where z = itabLits (nodeInfo n) showLit n = show (head $ nodeLits n) -- | Render a value using the current session view :: a -> IO () view a = do noSession <- isEmptyMVar sessionRef () <- when noSession $ newSession -- actually call into vacuum let dot = render. myPpDot . (showHNodes myStyle) $ vacuum a -- TODO check for path mdot <- findExecutable "dot" let exe = case mdot of Nothing -> error "\"dot\" executable not found. Please install graphviz" Just p -> p svgstring <- myReadProcess exe ["-Tsvg"] dot svg <- C.svgNewFromString svgstring writeFile "/tmp/demo" svgstring -- TODO destroy old svg canvas here. c <- modifyMVar sessionRef $ \(Session win canvas svg') -> do updateCanvas svg canvas return ((Session win canvas svg), (canvas)) -- hides expose events! G.widgetQueueDraw c yield return () -- | Render a value to a file viewFile :: String -> a -> IO () viewFile file a = do let dot = render . myPpDot . (showHNodes myStyle) $ vacuum a mdot <- findExecutable "dot" let exe = case mdot of Nothing -> error "\"dot\" executable not found. please install graphviz" Just p -> p svgstring <- myReadProcess exe ["-Tsvg"] dot writeFile file svgstring updateCanvas :: C.SVG -> G.DrawingArea -> IO Bool updateCanvas svg canvas = do win <- G.widgetGetDrawWindow canvas (width, height) <- G.widgetGetSize canvas let (w,h) = (fromIntegral width,fromIntegral height) (sw,sh) = C.svgGetSize svg G.renderWithDrawable win $ do C.setAntialias C.AntialiasDefault C.setLineCap C.LineCapSquare C.scale (w / fromIntegral sw) (h / fromIntegral sh) C.svgRender svg return True ------------------------------------------------------------------------ -- UI -- do action m for any keypress (except meta keys) anyKey :: (Monad m) => m a -> G.Event -> m Bool anyKey m (G.Key {G.eventKeyName=key}) | any (`isPrefixOf` key) ignores = return True | otherwise = m >> return True where ignores = ["Shift","Control","Alt", "Super","Meta","Hyper"] type SVGString = String renderableToWindow :: SVGString -> IO () renderableToWindow chart = do svg <- C.svgNewFromString chart G.unsafeInitGUIForThreadedRTS -- G.initGUI window <- G.windowNew canvas <- G.drawingAreaNew -- fix size -- G.windowSetResizable window False -- G.widgetSetSizeRequest window windowWidth windowHeight -- press any key to quit G.onKeyPress window $ \e -> case e of G.Key {G.eventKeyName=key} | key == "r" -> do return True _ -> anyKey (G.widgetDestroy window) e G.onDestroy window G.mainQuit G.onExpose canvas $ const (updateCanvas svg canvas) G.set window [G.containerChild G.:= canvas] G.widgetShowAll window G.mainGUI ------------------------------------------------------------------------ -- Talking to dot myReadProcess :: FilePath -- ^ command to run -> [String] -- ^ any arguments -> String -- ^ standard input -> IO String -- ^ stdout + stderr myReadProcess cmd args input = do (Just inh, Just outh, _, pid) <- createProcess (proc cmd args){ std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } -- fork off a thread to start consuming the output output <- hGetContents outh outMVar <- newEmptyMVar forkIO $ C.evaluate (length output) >> putMVar outMVar () -- now write and flush any input when (not (null input)) $ do hPutStr inh input; hFlush inh hClose inh -- done with stdin -- wait on the output takeMVar outMVar hClose outh -- wait on the process ex <- waitForProcess pid case ex of ExitSuccess -> return output ExitFailure r -> return output {- ioError (mkIOError OtherError ("readProcess: " ++ cmd ++ ' ':unwords (map show args) ++ " (exit " ++ show r ++ ")") Nothing Nothing) -} ------------------------------------------------------------------------ welcome = unlines ["", "", "", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " image/svg+xml", " ", " ", " ", " ", " ", " ", " ", " g", " ", " ", " Node|0", " Node", " ", " ", " (:)|1", " (:)", " ", " ", " Node|0->(:)|1", " ", " ", " ", " ", " (,)|2", " (,)", " ", " ", " (:)|1->(,)|2", " ", " ", " ", " ", " (:)|3", " (:)", " ", " ", " (:)|1->(:)|3", " ", " ", " ", " ", " (,)|4", " (,)", " ", " ", " (,)|2->(,)|4", " ", " ", " ", " ", " Leaf|5", " Leaf", " ", " ", " (,)|2->Leaf|5", " ", " ", " ", " ", " (,)|16", " (,)", " ", " ", " (:)|3->(,)|16", " ", " ", " ", " ", " (:)|17", " (:)", " ", " ", " (:)|3->(:)|17", " ", " ", " ", " ", " (:)|6", " (:)", " ", " ", " (,)|4->(:)|6", " ", " ", " ", " ", " Sum[1]|7", " Sum[1]", " ", " ", " (,)|4->Sum[1]|7", " ", " ", " ", " ", " (,)|16->Leaf|5", " ", " ", " ", " ", " (,)|18", " (,)", " ", " ", " (,)|16->(,)|18", " ", " ", " ", " ", " (,)|21", " (,)", " ", " ", " (:)|17->(,)|21", " ", " ", " ", " ", " (:)|22", " (:)", " ", " ", " (:)|17->(:)|22", " ", " ", " ", " ", " 1|8", " 1", " ", " ", " (:)|6->1|8", " ", " ", " ", " ", " (:)|9", " (:)", " ", " ", " (:)|6->(:)|9", " ", " ", " ", " ", " Sum[1]|7->(:)|9", " ", " ", " ", " ", " 2|10", " 2", " ", " ", " (:)|9->2|10", " ", " ", " ", " ", " (:)|11", " (:)", " ", " ", " (:)|9->(:)|11", " ", " ", " ", " ", " 3|12", " 3", " ", " ", " (:)|11->3|12", " ", " ", " ", " ", " (:)|13", " (:)", " ", " ", " (:)|11->(:)|13", " ", " ", " ", " ", " 4|14", " 4", " ", " ", " (:)|13->4|14", " ", " ", " ", " ", " []|15", " []", " ", " ", " (:)|13->[]|15", " ", " ", " ", " ", " (:)|19", " (:)", " ", " ", " (,)|18->(:)|19", " ", " ", " ", " ", " Sum[1]|20", " Sum[1]", " ", " ", " (,)|18->Sum[1]|20", " ", " ", " ", " ", " (,)|21->Leaf|5", " ", " ", " ", " ", " (,)|23", " (,)", " ", " ", " (,)|21->(,)|23", " ", " ", " ", " ", " (:)|22->[]|15", " ", " ", " ", " ", " (,)|26", " (,)", " ", " ", " (:)|22->(,)|26", " ", " ", " ", " ", " (:)|19->2|10", " ", " ", " ", " ", " (:)|19->(:)|11", " ", " ", " ", " ", " Sum[1]|20->(:)|11", " ", " ", " ", " ", " (:)|24", " (:)", " ", " ", " (,)|23->(:)|24", " ", " ", " ", " ", " Sum[1]|25", " Sum[1]", " ", " ", " (,)|23->Sum[1]|25", " ", " ", " ", " ", " (,)|26->Leaf|5", " ", " ", " ", " ", " (,)|27", " (,)", " ", " ", " (,)|26->(,)|27", " ", " ", " ", " ", " (:)|24->3|12", " ", " ", " ", " ", " (:)|24->(:)|13", " ", " ", " ", " ", " Sum[1]|25->(:)|13", " ", " ", " ", " ", " (:)|28", " (:)", " ", " ", " (,)|27->(:)|28", " ", " ", " ", " ", " Sum[1]|29", " Sum[1]", " ", " ", " (,)|27->Sum[1]|29", " ", " ", " ", " ", " (:)|28->4|14", " ", " ", " ", " ", " (:)|28->[]|15", " ", " ", " ", " ", " Sum[1]|29->[]|15", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " Vacuum:LiveHaskellDataVisualization", " ", " Type any key to close", " ", " ", ""]