diff --git a/System/Vacuum/Cairo.hs b/System/Vacuum/Cairo.hs --- a/System/Vacuum/Cairo.hs +++ b/System/Vacuum/Cairo.hs @@ -12,29 +12,134 @@ -- Will display a pop-up window of the data structure produced -- -module System.Vacuum.Cairo (view) where +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 +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 800 600 + renderableToWindow svg +-} ------------------------------------------------------------------------ -- UI @@ -49,8 +154,8 @@ type SVGString = String -renderableToWindow :: SVGString -> Int -> Int -> IO () -renderableToWindow chart windowWidth windowHeight = do +renderableToWindow :: SVGString -> IO () +renderableToWindow chart = do svg <- C.svgNewFromString chart G.unsafeInitGUIForThreadedRTS @@ -59,27 +164,21 @@ canvas <- G.drawingAreaNew -- fix size -- G.windowSetResizable window False - G.widgetSetSizeRequest window windowWidth windowHeight +-- G.widgetSetSizeRequest window windowWidth windowHeight + -- press any key to quit - G.onKeyPress window $ anyKey (G.widgetDestroy window) + 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 -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 @@ -121,3 +220,161 @@ Nothing Nothing) -} + + +------------------------------------------------------------------------ + +welcome = unlines + ["", + "", + "", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " image/svg+xml", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + ""] diff --git a/vacuum-cairo.cabal b/vacuum-cairo.cabal --- a/vacuum-cairo.cabal +++ b/vacuum-cairo.cabal @@ -1,5 +1,5 @@ name: vacuum-cairo -version: 0.1 +version: 0.2 cabal-version: >= 1.2 build-type: Simple license: BSD3 @@ -27,8 +27,10 @@ library build-depends: base >= 3, - vacuum, + vacuum >= 0.0.5, gtk, + parallel, + strict-concurrency, cairo, svgcairo, process,