diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -3,11 +3,14 @@
import Distribution.Simple
import Distribution.Simple.Setup
import Distribution.Simple.LocalBuildInfo
+import Distribution.PackageDescription (PackageDescription)
import System.FilePath
-main = defaultMainWithHooks $
- simpleUserHooks { postInst = postInstHook (postInst simpleUserHooks) }
+main = defaultMainWithHooks $ simpleUserHooks
+ { postInst = postInstHook (postInst simpleUserHooks)
+ , postConf = postConfHook (postConf simpleUserHooks)
+ }
postInstHook oldHook args iflags pDesc lbi = do
let instDataDir = datadir $ absoluteInstallDirs pDesc lbi (fromFlag $ copyDest defaultCopyFlags)
@@ -15,3 +18,8 @@
putStrLn $ "echo \":script " ++ (instDataDir "ghci") ++ "\" >> ~/.ghci"
oldHook args iflags pDesc lbi
+
+postConfHook oldHook args flags descr buildInfo = case profFlag of
+ Flag True -> error "This library cannot be built using profiling. Try invoking cabal with the --disable-library-profiling flag."
+ _ -> oldHook args flags descr buildInfo
+ where profFlag = configProfLib $ configFlags buildInfo
diff --git a/data/legend_graph.svg b/data/legend_graph.svg
new file mode 100644
--- /dev/null
+++ b/data/legend_graph.svg
@@ -0,0 +1,177 @@
+
+
+
+
diff --git a/data/legend_list.svg b/data/legend_list.svg
new file mode 100644
--- /dev/null
+++ b/data/legend_list.svg
@@ -0,0 +1,236 @@
+
+
+
+
diff --git a/data/main.ui b/data/main.ui
new file mode 100644
--- /dev/null
+++ b/data/main.ui
@@ -0,0 +1,311 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/data/welcome.svg b/data/welcome.svg
new file mode 100644
--- /dev/null
+++ b/data/welcome.svg
@@ -0,0 +1,1487 @@
+
+
+
+
diff --git a/ghc-vis.cabal b/ghc-vis.cabal
--- a/ghc-vis.cabal
+++ b/ghc-vis.cabal
@@ -1,5 +1,5 @@
name: ghc-vis
-version: 0.5
+version: 0.6
license: BSD3
license-file: LICENSE
category: GHC, Debug, Development
@@ -21,16 +21,24 @@
tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1
-data-files: ghci
+data-files: ghci data/main.ui data/welcome.svg data/legend_graph.svg data/legend_list.svg
Extra-source-files: nonghci-test.hs
flag graph
Default: True
Description: "Enable graph view using Graphviz"
+flag full
+ Default: True
+ Description: "Full ghc-vis window: decorations, buttons, legend"
+
+flag sdl
+ Default: False
+ Description: "SDL window"
+
Library
Exposed-modules: GHC.Vis
- Other-modules: GHC.Vis.Internal GHC.Vis.Types GHC.Vis.View.List GHC.Vis.View.Common
+ Other-modules: GHC.Vis.Internal GHC.Vis.Types GHC.Vis.View.List GHC.Vis.View.Common Paths_ghc_vis
Default-Language: Haskell2010
Build-depends: base == 4.*,
mtl >= 2.0,
@@ -50,6 +58,15 @@
xdot >= 0.2
Cpp-options: -DGRAPH_VIEW
---source-repository head
--- type: darcs
--- location: http://
+ if flag(full)
+ Build-depends: svgcairo >= 0.12
+ Cpp-options: -DFULL_WINDOW
+
+ if flag(sdl)
+ Build-depends: SDL >= 0.6,
+ cairo >= 0.12.4
+ Cpp-options: -DSDL_WINDOW
+
+source-repository head
+ type: git
+ location: git://r0q.ath.cx/vis
diff --git a/ghci b/ghci
--- a/ghci
+++ b/ghci
@@ -1,4 +1,6 @@
-:def vis \_ -> return $ "GHC.Vis.visualization"
+:def vis \_ -> return $ "GHC.Vis.vis"
+:def mvis \_ -> return $ "GHC.Vis.mvis"
+:def svis \_ -> return $ "GHC.Vis.svis"
:def view \x -> return $ "GHC.Vis.view (" ++ x ++ ") " ++ show x
:def eval \x -> return $ "GHC.Vis.eval \"" ++ x ++ "\""
:def switch \_ -> return $ "GHC.Vis.switch"
diff --git a/src/GHC/Vis.hs b/src/GHC/Vis.hs
--- a/src/GHC/Vis.hs
+++ b/src/GHC/Vis.hs
@@ -34,7 +34,11 @@
> putStrLn "End"
-}
module GHC.Vis (
- visualization, -- TODO: Maybe rename to vis
+ vis,
+ mvis,
+#ifdef SDL_WINDOW
+ svis,
+#endif
view,
eval,
switch,
@@ -50,7 +54,7 @@
import Prelude hiding (error)
#endif
-import Graphics.UI.Gtk hiding (Box, Signal)
+import Graphics.UI.Gtk hiding (Box, Signal, get, response)
import qualified Graphics.UI.Gtk.Gdk.Events as E
import System.IO
@@ -79,6 +83,16 @@
import Graphics.Rendering.Cairo
+#ifdef FULL_WINDOW
+import Graphics.Rendering.Cairo.SVG
+import Paths_ghc_vis as My
+#endif
+
+#ifdef SDL_WINDOW
+import qualified Graphics.UI.SDL as SDL
+import Foreign.Ptr ( castPtr )
+#endif
+
views :: [View]
views =
View List.redraw List.click List.move List.updateObjects List.export :
@@ -108,13 +122,38 @@
signalTimeout :: Int
signalTimeout = 1000000
+#ifdef SDL_WINDOW
+black = SDL.Pixel maxBound
+white = SDL.Pixel 0xFFFFFF
+#endif
+
-- | This is the main function. It's to be called from GHCi and launches a
-- graphical window in a new thread.
-visualization :: IO ()
-visualization = do
+vis :: IO ()
+#ifdef FULL_WINDOW
+vis = do
vr <- swapMVar visRunning True
unless vr $ void $ forkIO visMainThread
+#else
+vis = mvis
+#endif
+-- | A minimalistic version of ghc-vis, without window decorations, help and
+-- all that other stuff.
+mvis :: IO ()
+mvis = do
+ vr <- swapMVar visRunning True
+ unless vr $ void $ forkIO mVisMainThread
+
+#ifdef SDL_WINDOW
+-- | SDL version. Not properly working yet. Mainly for testing whether SDL
+-- works better than GTK on some platforms.
+svis :: IO ()
+svis = do
+ vr <- swapMVar visRunning True
+ unless vr $ void $ forkIO sdlVisMainThread
+#endif
+
-- | Add expressions with a name to the visualization window.
view :: a -> String -> IO ()
view a name = put $ NewSignal (asBox a) name
@@ -140,10 +179,15 @@
-- | Export the current visualization view to a file, format depends on the
-- file ending. Currently supported: svg, png, pdf, ps
export :: String -> IO ()
-export filename = case mbDrawFn of
- Right error -> putStrLn error
- Left _ -> put $ ExportSignal ((\(Left x) -> x) mbDrawFn) filename
+export filename = void $ export' filename
+export' :: String -> IO (Maybe String)
+export' filename = case mbDrawFn of
+ Right error -> do putStrLn error
+ return $ Just error
+ Left _ -> do put $ ExportSignal ((\(Left x) -> x) mbDrawFn) filename
+ return Nothing
+
where mbDrawFn = case map toLower (reverse . take 4 . reverse $ filename) of
".svg" -> Left withSVGSurface
".pdf" -> Left withPDFSurface
@@ -161,8 +205,8 @@
put :: Signal -> IO ()
put s = void $ timeout signalTimeout $ putMVar visSignal s
-visMainThread :: IO ()
-visMainThread = do
+mVisMainThread :: IO ()
+mVisMainThread = do
initGUI
window <- windowNew
@@ -180,6 +224,50 @@
runCorrect move >>= \f -> f canvas
return True
+ dummy <- windowNew
+
+ setupGUI window canvas dummy
+
+#ifdef SDL_WINDOW
+sdlVisMainThread :: IO ()
+sdlVisMainThread = SDL.withInit [ SDL.InitVideo ] $ do
+ screen <- SDL.setVideoMode 600 600 32 [ SDL.Resizable ]
+
+ SDL.fillRect screen Nothing black
+
+ pixels <- fmap castPtr $ SDL.surfaceGetPixels screen
+
+ -- Here we test the first of the user facing functions added by the patch.
+ -- Be sure to use FORMATRGB24 so Cairo and SDL don't conflict about alpha
+ -- values. If you need to use alpha channel in your Cairo routines, consider
+ -- using an independent Cairo surface to buffer your alpha drawing to.
+ --renderWith canvas demo1
+
+ -- And here is the other new function for when you want to hide the
+ -- Cairo.Surface from the caller.
+
+ canvas <- createImageSurfaceForData pixels FormatRGB24 600 600 (600 * 4)
+
+ reactThread <- forkIO $ react2
+
+ let idle = do
+ e <- SDL.waitEvent
+ case e of
+ SDL.Quit -> quit reactThread
+ otherwise -> do
+ putStrLn "Updating"
+ s <- List.getState
+ SDL.fillRect screen Nothing white
+ boundingBoxes <- renderWith canvas $ List.draw s 600 600
+ List.updateBoundingBoxes boundingBoxes
+ SDL.flip screen
+ idle
+
+ idle
+#endif
+
+setupGUI :: (WidgetClass w1, WidgetClass w2, WidgetClass w3) => w1 -> w2 -> w3 -> IO ()
+setupGUI window canvas legendCanvas = do
onMotionNotify canvas False $ \e -> do
state <- readIORef visState
modifyIORef visState (\s -> s {mousePos = (E.eventX e, E.eventY e)})
@@ -316,7 +404,7 @@
widgetShowAll window
- reactThread <- forkIO $ react canvas window
+ reactThread <- forkIO $ react canvas legendCanvas
--onDestroy window mainQuit -- Causes :r problems with multiple windows
onDestroy window (quit reactThread)
@@ -328,8 +416,64 @@
swapMVar visRunning False
killThread reactThread
+#ifdef SDL_WINDOW
+react2 :: IO b
+react2 = do
+ -- Timeout used to handle ghci reloads (:r)
+ -- Reloads cause the visSignal to be reinitialized, but takeMVar is still
+ -- waiting for the old one. This solution is not perfect, but it works for
+ -- now.
+ mbSignal <- timeout signalTimeout (takeMVar visSignal)
+ case mbSignal of
+ Nothing -> do
+ running <- readMVar visRunning
+ if running then react2 else
+ -- :r caused visRunning to be reset
+ (do swapMVar visRunning True
+ timeout signalTimeout (putMVar visSignal UpdateSignal)
+ react2)
+ Just signal -> do
+ case signal of
+ NewSignal x n -> modifyMVar_ visBoxes (
+ \y -> return $ if (x,n) `elem` y then y else y ++ [(x,n)])
+ ClearSignal -> modifyMVar_ visBoxes (\_ -> return [])
+ UpdateSignal -> return ()
+ SwitchSignal -> doSwitch
+ ExportSignal d f -> catch (runCorrect exportView >>= \e -> e d f)
+ (\e -> do let err = show (e :: IOException)
+ hPutStrLn stderr $ "Couldn't export to file \"" ++ f ++ "\": " ++ err
+ return ())
+
+ boxes <- readMVar visBoxes
+ performGC -- TODO: Else Blackholes appear. Do we want this?
+ -- Blackholes stop our current thread and only resume after
+ -- they have been replaced with their result, thereby leading
+ -- to an additional element in the HeapMap we don't want.
+ -- Example for bad behaviour that would happen then:
+ -- λ> let xs = [1..42] :: [Int]
+ -- λ> let x = 17 :: Int
+ -- λ> let ys = [ y | y <- xs, y >= x ]
+
+ runCorrect updateObjects >>= \f -> f boxes
+
+ --postGUISync $ widgetQueueDraw canvas
+ --postGUISync $ widgetQueueDraw legendCanvas
+ react2
+
+#ifdef GRAPH_VIEW
+ where doSwitch = isGraphvizInstalled >>= \gvi -> if gvi
+ then modifyIORef visState (\s -> s {T.view = succN (T.view s), zoomRatio = 1, position = (0, 0)})
+ else putStrLn "Cannot switch view: Graphviz not installed"
+
+ succN GraphView = ListView
+ succN ListView = GraphView
+#else
+ where doSwitch = putStrLn "Cannot switch view: Graph view disabled at build"
+#endif
+#endif
+
react :: (WidgetClass w1, WidgetClass w2) => w1 -> w2 -> IO b
-react canvas window = do
+react canvas legendCanvas = do
-- Timeout used to handle ghci reloads (:r)
-- Reloads cause the visSignal to be reinitialized, but takeMVar is still
-- waiting for the old one. This solution is not perfect, but it works for
@@ -338,15 +482,15 @@
case mbSignal of
Nothing -> do
running <- readMVar visRunning
- if running then react canvas window else
+ if running then react canvas legendCanvas else
-- :r caused visRunning to be reset
(do swapMVar visRunning True
timeout signalTimeout (putMVar visSignal UpdateSignal)
- react canvas window)
+ react canvas legendCanvas)
Just signal -> do
case signal of
NewSignal x n -> modifyMVar_ visBoxes (
- \y -> if (x,n) `elem` y then return y else return $ y ++ [(x,n)])
+ \y -> return $ if (x,n) `elem` y then y else y ++ [(x,n)])
ClearSignal -> modifyMVar_ visBoxes (\_ -> return [])
UpdateSignal -> return ()
SwitchSignal -> doSwitch
@@ -368,7 +512,8 @@
runCorrect updateObjects >>= \f -> f boxes
postGUISync $ widgetQueueDraw canvas
- react canvas window
+ postGUISync $ widgetQueueDraw legendCanvas
+ react canvas legendCanvas
#ifdef GRAPH_VIEW
where doSwitch = isGraphvizInstalled >>= \gvi -> if gvi
@@ -399,6 +544,117 @@
newPos = (oldPosX * zoom, oldPosY * zoom)
return newPos
+
+#ifdef FULL_WINDOW
+visMainThread :: IO ()
+visMainThread = do
+ initGUI
+
+ mainUIFile <- My.getDataFileName "data/main.ui"
+ builder <- builderNew
+ builderAddFromFile builder mainUIFile
+
+ let get :: forall cls . GObjectClass cls
+ => (GObject -> cls)
+ -> String
+ -> IO cls
+ get = builderGetObject builder
+
+ window <- get castToWindow "window"
+ canvas <- get castToDrawingArea "drawingarea"
+
+ saveDialog <- get castToFileChooserDialog "savedialog"
+ aboutDialog <- get castToAboutDialog "aboutdialog"
+
+ legendDialog <- get castToWindow "legenddialog"
+ legendCanvas <- get castToDrawingArea "legenddrawingarea"
+
+ newFilter "*.pdf" "PDF" saveDialog
+ newFilter "*.svg" "SVG" saveDialog
+ newFilter "*.ps" "PostScript" saveDialog
+ newFilter "*.png" "PNG" saveDialog
+
+ onResponse saveDialog $ fileSave saveDialog
+ onResponse aboutDialog $ const $ widgetHide aboutDialog
+
+ onDelete saveDialog $ const $ widgetHide saveDialog >> return True
+ onDelete aboutDialog $ const $ widgetHide aboutDialog >> return True
+ onDelete legendDialog $ const $ widgetHide legendDialog >> return True
+
+ get castToMenuItem "clear" >>= \item -> onActivateLeaf item clear
+ get castToMenuItem "switch" >>= \item -> onActivateLeaf item switch
+ get castToMenuItem "update" >>= \item -> onActivateLeaf item update
+ get castToMenuItem "export" >>= \item -> onActivateLeaf item $ widgetShow saveDialog
+ get castToMenuItem "quit" >>= \item -> onActivateLeaf item $ widgetDestroy window
+ get castToMenuItem "about" >>= \item -> onActivateLeaf item $ widgetShow aboutDialog
+ get castToMenuItem "legend" >>= \item -> onActivateLeaf item $ widgetShow legendDialog
+
+ widgetModifyBg canvas StateNormal backgroundColor
+ widgetModifyBg legendCanvas StateNormal backgroundColor
+
+ welcomeSVG <- My.getDataFileName "data/welcome.svg" >>= svgNewFromFile
+
+ legendListSVG <- My.getDataFileName "data/legend_list.svg" >>= svgNewFromFile
+ legendGraphSVG <- My.getDataFileName "data/legend_graph.svg" >>= svgNewFromFile
+
+ onExpose canvas $ const $ do
+ boxes <- readMVar visBoxes
+
+ if null boxes
+ then renderSVGScaled canvas welcomeSVG
+ else do
+ runCorrect redraw >>= \f -> f canvas
+ runCorrect move >>= \f -> f canvas
+ return True
+
+ onExpose legendCanvas $ const $ do
+ state <- readIORef visState
+ renderSVGScaled legendCanvas $ case T.view state of
+ ListView -> legendListSVG
+ GraphView -> legendGraphSVG
+
+ setupGUI window canvas legendCanvas
+
+fileSave :: FileChooserDialog -> ResponseId -> IO ()
+fileSave fcdialog response = do
+ case response of
+ ResponseOk -> do Just filename <- fileChooserGetFilename fcdialog
+ mbError <- export' filename
+ case mbError of
+ Nothing -> return ()
+ Just error -> do
+ errorDialog <- messageDialogNew Nothing [] MessageError ButtonsOk error
+ widgetShow errorDialog
+ onResponse errorDialog $ const $ widgetHide errorDialog
+ return ()
+ _ -> return ()
+ widgetHide fcdialog
+
+newFilter :: FileChooserClass fc => String -> String -> fc -> IO ()
+newFilter filterString name dialog = do
+ filt <- fileFilterNew
+ fileFilterAddPattern filt filterString
+ fileFilterSetName filt $ name ++ " (" ++ filterString ++ ")"
+ fileChooserAddFilter dialog filt
+
+renderSVGScaled :: (WidgetClass w) => w -> SVG -> IO Bool
+renderSVGScaled canvas svg = do
+ E.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas
+ win <- widgetGetDrawWindow canvas
+ renderWithDrawable win $ do
+ let (cx2, cy2) = svgGetSize svg
+
+ (rw,rh) = (fromIntegral rw2, fromIntegral rh2)
+ (cx,cy) = (fromIntegral cx2, fromIntegral cy2)
+
+ -- Proportional scaling
+ (sx,sy) = (min (rw/cx) (rh/cy), sx)
+ (ox,oy) = (rw/2 - sx*cx/2, rh/2 - sy*cy/2)
+
+ translate ox oy
+ scale sx sy
+ svgRender svg
+#endif
-- Zoom into mouse, but only working from (0,0)
-- newPos = ( oldPosX + x * zoomRatio s - x * newZoomRatio
diff --git a/src/GHC/Vis/Types.hs b/src/GHC/Vis/Types.hs
--- a/src/GHC/Vis/Types.hs
+++ b/src/GHC/Vis/Types.hs
@@ -28,6 +28,7 @@
import Graphics.UI.Gtk hiding (Box, Signal, Point)
import Graphics.Rendering.Cairo
+-- | A simple Point
type Point = (Double, Double)
-- | A function to draw a cairo drawing to a file.
@@ -83,6 +84,7 @@
, heapMap' :: HeapMap
}
+-- | The state of a printing operation
type PrintState = MS.State PState
-- | Simple representation of objects on the heap, so they can be arranged linearly
diff --git a/src/GHC/Vis/View/Graph/Parser.hs b/src/GHC/Vis/View/Graph/Parser.hs
--- a/src/GHC/Vis/View/Graph/Parser.hs
+++ b/src/GHC/Vis/View/Graph/Parser.hs
@@ -12,6 +12,8 @@
)
where
+import Data.List
+
import Control.Monad
import qualified Data.Text.Lazy as B
@@ -85,7 +87,7 @@
mbEdges xs (p,c) = return $ map (\b -> (p, boxPos b)) (allPtrs c) ++ xs
boxPos :: Box -> Maybe Int
- boxPos b = lookup b $ zip (map fst rhm) [0..]
+ boxPos b = elemIndex b $ map fst rhm
bcoChildren :: [Box] -> IO [Int]
bcoChildren [] = return []
@@ -120,6 +122,7 @@
defaultVis :: (Graph gr) => gr String String -> DotGraph Node
defaultVis = graphToDot nonClusteredParams
-- Somehow (X11Color Transparency) is white, use (RGBA 0 0 0 0) instead
+ -- Ordering OutEdges is not strong enough to force edge ordering, might not look good anyway
{ globalAttributes = [GraphAttrs [BgColor [RGBA 0 0 0 0], FontName fontName, FontSize graphFontSize]]
, fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize]
--, fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize, Style [SItem Filled []], FillColor [RGBA 255 255 255 255], Color [RGBA 0 0 0 255]]
diff --git a/src/GHC/Vis/View/List.hs b/src/GHC/Vis/View/List.hs
--- a/src/GHC/Vis/View/List.hs
+++ b/src/GHC/Vis/View/List.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes #-}
{- |
Module : GHC.Vis.View.List
Copyright : (c) Dennis Felsing
@@ -8,6 +8,13 @@
-}
module GHC.Vis.View.List (
export,
+
+#ifdef SDL_WINDOW
+ getState,
+ draw,
+ updateBoundingBoxes,
+#endif
+
redraw,
click,
move,
@@ -91,6 +98,15 @@
boundingBoxes <- render canvas (draw s rw2 rh2)
modifyIORef state (\s' -> s' {bounds = boundingBoxes})
+
+#ifdef SDL_WINDOW
+getState :: IO State
+getState = readIORef state
+
+updateBoundingBoxes :: [(String, Rectangle)] -> IO ()
+updateBoundingBoxes boundingBoxes = do
+ modifyIORef state (\s' -> s' {bounds = boundingBoxes})
+#endif
-- | Export the visualization to an SVG file
export :: DrawFunction -> String -> IO ()