vacuum-cairo-0.2: System/Vacuum/Cairo.hs
--
-- |
-- 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
) 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 Data.List
import System.Process
import Control.Concurrent (forkIO,yield)
import System.IO
import Control.Monad
import System.Exit
import qualified Control.Exception as C
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.widgetSetSizeRequest window 400 200
G.set window [G.containerChild G.:= canvas]
G.widgetShowAll window
forkIO G.mainGUI
let s = Session {
sWindow = window,
sDrawing = canvas,
sSVG = svg
}
putMVar sessionRef $! s
-- | Render a value using the current session
view :: a -> IO ()
view a = do
noSession <- isEmptyMVar sessionRef
() <- when noSession $ newSession
let dot = render. ppDot . nameGraph $ vacuum a
rnf dot `seq` return ()
-- TODO check for path
svgstring <- myReadProcess "dot" ["-Tsvg"] dot
svg <- C.svgNewFromString 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
-- performGC
yield
return ()
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.scale (w / fromIntegral sw) (h / fromIntegral sh)
C.svgRender svg
return True
------------------------------------------------------------------------
{-
-- | Render a 'vacuum' image of the heap on a pop-up cairo canvas
view :: a -> IO ()
view a = do
let dot = render. ppDot . nameGraph $ vacuum a
svg <- myReadProcess "dot" ["-Tsvg"] dot
renderableToWindow svg
-}
------------------------------------------------------------------------
-- 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
["<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>",
"<!-- Created with Inkscape (http://www.inkscape.org/) -->",
"<svg",
" xmlns:dc=\"http://purl.org/dc/elements/1.1/\"",
" xmlns:cc=\"http://web.resource.org/cc/\"",
" xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"",
" xmlns:svg=\"http://www.w3.org/2000/svg\"",
" xmlns=\"http://www.w3.org/2000/svg\"",
" xmlns:xlink=\"http://www.w3.org/1999/xlink\"",
" xmlns:sodipodi=\"http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd\"",
" xmlns:inkscape=\"http://www.inkscape.org/namespaces/inkscape\"",
" width=\"260\"",
" height=\"270\"",
" id=\"svg2\"",
" sodipodi:version=\"0.32\"",
" inkscape:version=\"0.45\"",
" sodipodi:docbase=\"/home/david/Inkscape Files/Wiki\"",
" sodipodi:docname=\"GTK.svg\"",
" inkscape:output_extension=\"org.inkscape.output.svg.inkscape\"",
" version=\"1.0\"",
" sodipodi:modified=\"true\">",
" <defs",
" id=\"defs4\">",
" <linearGradient",
" inkscape:collect=\"always\"",
" id=\"linearGradient2259\">",
" <stop",
" style=\"stop-color:#fe798e;stop-opacity:1\"",
" offset=\"0\"",
" id=\"stop2261\" />",
" <stop",
" style=\"stop-color:#9c2219;stop-opacity:1\"",
" offset=\"1\"",
" id=\"stop2263\" />",
" </linearGradient>",
" <linearGradient",
" inkscape:collect=\"always\"",
" id=\"linearGradient2251\">",
" <stop",
" style=\"stop-color:#bff872;stop-opacity:1\"",
" offset=\"0\"",
" id=\"stop2253\" />",
" <stop",
" style=\"stop-color:#7de567;stop-opacity:1\"",
" offset=\"1\"",
" id=\"stop2255\" />",
" </linearGradient>",
" <linearGradient",
" inkscape:collect=\"always\"",
" id=\"linearGradient2243\">",
" <stop",
" style=\"stop-color:#92cbe2;stop-opacity:1\"",
" offset=\"0\"",
" id=\"stop2245\" />",
" <stop",
" style=\"stop-color:#7f95fe;stop-opacity:1\"",
" offset=\"1\"",
" id=\"stop2247\" />",
" </linearGradient>",
" <linearGradient",
" inkscape:collect=\"always\"",
" xlink:href=\"#linearGradient2243\"",
" id=\"linearGradient2285\"",
" gradientUnits=\"userSpaceOnUse\"",
" gradientTransform=\"translate(92.2254,-0.313709)\"",
" x1=\"-143\"",
" y1=\"207.36218\"",
" x2=\"-129.5\"",
" y2=\"108.86218\" />",
" <linearGradient",
" inkscape:collect=\"always\"",
" xlink:href=\"#linearGradient2251\"",
" id=\"linearGradient2287\"",
" gradientUnits=\"userSpaceOnUse\"",
" gradientTransform=\"translate(92.2254,-0.313709)\"",
" x1=\"-133.5\"",
" y1=\"221.86218\"",
" x2=\"-50\"",
" y2=\"279.36218\" />",
" <linearGradient",
" inkscape:collect=\"always\"",
" xlink:href=\"#linearGradient2259\"",
" id=\"linearGradient2289\"",
" gradientUnits=\"userSpaceOnUse\"",
" gradientTransform=\"translate(92.2254,-0.313709)\"",
" x1=\"-157.5\"",
" y1=\"222.86218\"",
" x2=\"-247.5\"",
" y2=\"276.86218\" />",
" </defs>",
" <sodipodi:namedview",
" id=\"base\"",
" pagecolor=\"#ffffff\"",
" bordercolor=\"#666666\"",
" borderopacity=\"1.0\"",
" gridtolerance=\"10000\"",
" guidetolerance=\"10\"",
" objecttolerance=\"10\"",
" inkscape:pageopacity=\"0.0\"",
" inkscape:pageshadow=\"2\"",
" inkscape:zoom=\"1\"",
" inkscape:cx=\"292.4078\"",
" inkscape:cy=\"237.54502\"",
" inkscape:document-units=\"px\"",
" inkscape:current-layer=\"layer1\"",
" inkscape:window-width=\"1280\"",
" inkscape:window-height=\"948\"",
" inkscape:window-x=\"0\"",
" inkscape:window-y=\"24\"",
" width=\"260px\"",
" height=\"270px\" />",
" <metadata",
" id=\"metadata7\">",
" <rdf:RDF>",
" <cc:Work",
" rdf:about=\"\">",
" <dc:format>image/svg+xml</dc:format>",
" <dc:type",
" rdf:resource=\"http://purl.org/dc/dcmitype/StillImage\" />",
" </cc:Work>",
" </rdf:RDF>",
" </metadata>",
" <g",
" inkscape:label=\"Layer 1\"",
" inkscape:groupmode=\"layer\"",
" id=\"layer1\"",
" transform=\"translate(-45.007449,-54.076718)\">",
" <g",
" id=\"g2279\"",
" transform=\"translate(224,-34.5)\">",
" <path",
" sodipodi:nodetypes=\"ccccc\"",
" style=\"fill:url(#linearGradient2285);fill-opacity:1\"",
" d=\"M -58.11348,213.41831 L -162.26826,151.37974 L -37.01785,100.04846 L 68.1307,158.15264 L -58.11348,213.41831 z \"",
" id=\"path2231\" />",
" <path",
" style=\"fill:url(#linearGradient2287);fill-opacity:1\"",
" d=\"M -51.56037,213.5916 L 72.03976,159.30293 L 54.30386,283.51375 L -62.14067,350.24024 L -51.56037,213.5916 z \"",
" id=\"path2229\"",
" sodipodi:nodetypes=\"ccccc\" />",
" <path",
" sodipodi:nodetypes=\"ccccc\"",
" style=\"fill:url(#linearGradient2289);fill-opacity:1\"",
" d=\"M -59.56037,347.18826 L -164.06037,282.96566 L -163.61166,159.3255 L -55.18554,215.49255 L -59.56037,347.18826 z \"",
" id=\"path2227\" />",
" <path",
" style=\"fill:#000000\"",
" d=\"M -66.27108,352.00632 C -69.30467,350.22909 -85.32501,339.74485 -101.87184,328.708 C -141.06516,302.56578 -152.91684,294.99749 -161.22644,290.80508 C -172.47362,285.13057 -171.42166,291.71277 -171.76785,224.84661 C -172.09132,162.36876 -172.8819,151.51349 -166.98072,153.09872 C -171.59657,148.70486 -149.89048,141.93362 -115.91158,126.8062 C -82.71848,112.02862 -46.04303,97.12968 -37.99045,95.151731 C -35.80415,94.614711 -30.58575,96.813551 -10.91381,106.56083 C 32.31874,127.98218 67.99593,147.7319 72.54924,152.76325 C 73.58759,153.91062 75.03553,154.84937 75.76688,154.84937 C 77.84679,154.84937 78.37332,158.95768 77.25844,166.48751 C 76.69538,170.29042 72.64193,195.0632 68.25078,221.53813 C 63.85962,248.01307 59.96508,272.38204 59.59625,275.69141 C 58.29011,287.41076 58.65986,286.97385 40.74281,297.9691 C 31.80145,303.4562 9.14236,316.66419 -9.61071,327.3202 C -28.36378,337.97622 -47.03613,348.65729 -51.10479,351.05592 C -55.17346,353.45455 -59.00931,355.3767 -59.62892,355.32736 C -60.24852,355.27802 -63.23749,353.78356 -66.27108,352.00632 z M -61.87106,326.08404 C -61.53987,317.12117 -60.90739,291.51119 -60.46556,269.17296 C -59.4846,219.57813 -59.22374,221.12454 -69.76193,214.06246 C -82.68227,205.404 -96.65592,197.35576 -120.42436,184.88302 C -133.38604,178.08124 -147.58846,170.35597 -151.98528,167.71576 C -157.4594,164.42865 -160.30462,163.24026 -161.01083,163.94598 C -162.29568,165.22992 -162.39159,217.12625 -161.17615,253.40053 L -160.31016,279.24588 L -153.15345,283.38712 C -146.97571,286.96188 -111.07469,311.08894 -76.29946,335.03636 C -70.50807,339.02452 -65.02796,342.30839 -64.12144,342.33386 C -62.68203,342.3743 -62.39695,340.31581 -61.87106,326.08404 z M -123.45447,281.63953 L -121.92862,231.56652 L -140.98255,221.52843 L -138.49408,200.85313 L -78.16426,229.52961 L -79.29283,248.93423 L -101.23414,239.89866 C -104.02169,251.08704 -104.55187,273.56224 -106.14867,290.70437 L -123.45447,281.63953 z M -9.61071,316.77116 C 34.17351,291.73098 48.95974,282.50651 49.5137,279.88608 C 49.76822,278.68213 50.70639,272.73304 51.59851,266.66586 C 52.49065,260.59869 56.34489,236.69937 60.1635,213.55627 C 66.55191,174.8386 67.87919,164.87776 66.64985,164.87776 C 65.35309,164.87776 41.87183,175.43096 11.95031,189.46143 C -6.52698,198.1256 -27.06009,207.7061 -33.67883,210.75142 C -40.29756,213.79674 -46.27431,216.80609 -46.96048,217.43886 C -49.01471,219.33318 -53.67591,334.1607 -51.88774,338.82058 C -51.3077,340.33214 -50.58188,340.15475 -45.46483,337.25078 C -42.2919,335.45011 -26.15754,326.23429 -9.61071,316.77116 z M -31.52427,299.57413 C -31.87775,272.99487 -33.95338,246.76003 -28.00983,218.92136 L -15.53109,218.69485 L -14.46997,256.84948 L 28.82336,204.1205 L 49.21858,198.81459 L 11.17117,250.94644 L 46.4177,267.81063 L 31.8401,277.19567 L -4.08659,261.22054 L -17.12774,267.67154 L -17.55651,293.33323 L -31.52427,299.57413 z M -44.98935,205.62376 C -42.07793,204.31693 -20.74221,194.22819 2.42335,183.20435 C 25.58892,172.18051 47.47586,161.89162 51.06101,160.34015 C 60.54302,156.23684 60.93348,155.67356 56.37503,152.674 C 49.35425,148.05414 13.69688,129.08139 -11.32169,116.65357 L -36.09795,104.34612 L -44.41536,107.15536 C -56.14763,111.11798 -89.54973,125.04344 -118.35237,137.97996 C -148.44864,151.49752 -152.51519,153.54112 -152.51519,155.14816 C -152.51519,155.84547 -145.85885,160.0994 -137.72332,164.60135 C -111.60287,179.05557 -54.81147,207.96913 -52.51064,207.98472 C -51.28536,207.99302 -47.90078,206.93059 -44.98935,205.62376 z M -60.75547,189.54567 C -75.28072,185.96717 -91.81229,177.57594 -96.0911,171.6097 C -99.47879,166.88602 -102.37326,159.22994 -102.37326,154.99297 C -102.37326,149.88393 -99.16092,142.63741 -94.96571,138.28271 C -89.64934,132.76424 -82.2461,130.42562 -63.03287,128.19542 C -43.93665,125.97879 -27.42575,126.6637 -17.57474,130.08117 C -8.29082,133.30188 -4.52834,135.30727 -2.61559,138.05436 C 2.38083,145.2301 5.93328,151.2196 5.93328,152.46787 C 5.93328,154.32106 1.29355,156.06801 -2.01293,155.45979 C -3.4339,155.1984 -6.26937,154.71168 -8.31397,154.3782 C -11.32445,153.88717 -12.45855,153.01191 -14.27723,149.776 C -16.85292,145.19318 -23.60657,140.51818 -30.15247,138.78687 C -40.15132,136.14228 -67.5992,138.35316 -76.05306,142.48406 C -80.82949,144.81802 -83.39709,149.93235 -84.08312,158.47883 C -84.55072,164.304 -84.36299,165.20843 -82.20604,167.52215 C -79.28527,170.65521 -71.09215,174.87312 -62.00697,177.92089 C -56.94497,179.61901 -54.0594,180.03115 -50.5755,179.55363 C -42.46315,178.44171 -41.49161,176.3237 -46.32188,170.28055 C -50.48755,165.06888 -51.4992,162.24318 -50.12122,159.66839 C -49.15472,157.86249 -48.34815,157.66756 -43.78911,158.13809 C -37.32875,158.80486 -23.72903,163.98325 -20.5194,166.99854 C -17.69425,169.65263 -17.2471,175.88082 -19.70523,178.33895 C -22.5073,181.14102 -34.94771,188.0685 -39.80016,189.52887 C -45.45811,191.23166 -53.88454,191.23841 -60.75547,189.54567 z \"",
" id=\"path2225\"",
" sodipodi:nodetypes=\"cssscssssssssssssccssssscccsscccccccccccssssssssscccccccccccccccssscccssssccssssssssssssssssssssssc\" />",
" </g>",
" </g>",
"</svg>"]