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 GHC.Vacuum
import Text.PrettyPrint
import Data.List

import System.Process
import Control.Concurrent
import System.IO
import Control.Monad
import System.Exit
import qualified Control.Exception as C

-- | 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 800 600

------------------------------------------------------------------------
-- 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 -> Int -> Int -> IO ()
renderableToWindow chart windowWidth windowHeight = 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 $ anyKey (G.widgetDestroy window)
    G.onDestroy window G.mainQuit
    G.onExpose canvas $ const (updateCanvas svg canvas)
    G.set window [G.containerChild G.:= canvas]
    G.widgetShowAll window
    G.mainGUI

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)
    let (sw,sh) = C.svgGetSize svg

    G.renderWithDrawable win $ do
        C.scale (w / fromIntegral sw) (h / fromIntegral sh)
        C.svgRender svg
    return True

------------------------------------------------------------------------
-- 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)

-}