diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009 Don Stewart + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/System/Vacuum/Cairo.hs b/System/Vacuum/Cairo.hs new file mode 100644 --- /dev/null +++ b/System/Vacuum/Cairo.hs @@ -0,0 +1,123 @@ +-- +-- | +-- 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) + +-} diff --git a/vacuum-cairo.cabal b/vacuum-cairo.cabal new file mode 100644 --- /dev/null +++ b/vacuum-cairo.cabal @@ -0,0 +1,36 @@ +name: vacuum-cairo +version: 0.1 +cabal-version: >= 1.2 +build-type: Simple +license: BSD3 +license-file: LICENSE +category: Development +author: Don Stewart +copyright: (c) Don Stewart 2009 +maintainer: Don Stewart +homepage: http://code.haskell.org/~dons/code/vacuum-cairo +stability: experimental +synopsis: Visualize live Haskell data structures using vacuum, graphviz and cairo +description: Visualize live Haskell data structures using vacuum, graphviz and cairo + . + > $ view "hello" + . + + . + > $ view [1..5] + . + + . + > $ view (IntMap.fromList $ zip [1..10] [1..]) + . + + +library + build-depends: base >= 3, + vacuum, + gtk, + cairo, + svgcairo, + process, + pretty + exposed-modules: System.Vacuum.Cairo