module GHC.Vis (
vis,
mvis,
#ifdef SDL_WINDOW
svis,
#endif
view,
eval,
switch,
update,
clear,
restore,
history,
setDepth,
export
)
where
#if __GLASGOW_HASKELL__ < 706
import Prelude hiding (catch)
#else
import Prelude
#endif
import Graphics.UI.Gtk hiding (Box, Signal, response)
import qualified Graphics.UI.Gtk.Gdk.Events as E
import System.IO
import Control.Concurrent
import Control.Monad
import Control.Exception hiding (evaluate)
import Data.Char
import Data.IORef
import Data.Version
import qualified Data.IntMap as M
import System.Timeout
import System.Mem
import GHC.HeapView hiding (name)
import GHC.Vis.Types hiding (view)
import qualified GHC.Vis.Types as T
import GHC.Vis.View.Common
import qualified GHC.Vis.View.List as List
#ifdef GRAPH_VIEW
import Data.GraphViz.Commands
import qualified GHC.Vis.View.Graph as Graph
#endif
import Graphics.Rendering.Cairo hiding (restore, x, y, width, height)
#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 :
#ifdef GRAPH_VIEW
View Graph.redraw Graph.click Graph.move Graph.updateObjects Graph.export :
#endif
[]
title :: String
title = "ghc-vis"
backgroundColor :: Color
backgroundColor = Color 0xffff 0xffff 0xffff
defaultSize :: (Int, Int)
defaultSize = (640, 480)
zoomIncrement :: Double
zoomIncrement = 1.25
positionIncrement :: Double
positionIncrement = 50
bigPositionIncrement :: Double
bigPositionIncrement = 200
signalTimeout :: Int
signalTimeout = 1000000
#ifdef SDL_WINDOW
black = SDL.Pixel maxBound
white = SDL.Pixel 0xFFFFFF
#endif
vis :: IO ()
#ifdef FULL_WINDOW
vis = do
vr <- swapMVar visRunning True
unless vr $ void $ forkIO visMainThread
#else
vis = mvis
#endif
mvis :: IO ()
mvis = do
vr <- swapMVar visRunning True
unless vr $ void $ forkIO mVisMainThread
#ifdef SDL_WINDOW
svis :: IO ()
svis = do
vr <- swapMVar visRunning True
unless vr $ void $ forkIO sdlVisMainThread
#endif
view :: a -> String -> IO ()
view a name = put $ NewSignal (asBox a) name
eval :: String -> IO ()
eval t = evaluate t >> update
switch :: IO ()
switch = put SwitchSignal
update :: IO ()
update = put UpdateSignal
clear :: IO ()
clear = put ClearSignal
restore :: IO ()
restore = put RestoreSignal
history :: (Int -> Int) -> IO ()
history = put . HistorySignal
setDepth :: Int -> IO ()
setDepth newDepth
| newDepth > 0 = modifyIORef visState (\s -> s {heapDepth = newDepth})
| otherwise = error "Heap depth has to be positive"
zoom :: WidgetClass w => w -> (Double -> Double) -> IO ()
zoom canvas f = do
state <- readIORef visState
let newZoomRatio = f $ zoomRatio state
newPos <- zoomImage canvas state newZoomRatio (mousePos state)
modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})
widgetQueueDraw canvas
movePos :: WidgetClass w => w -> (T.Point -> T.Point) -> IO ()
movePos canvas f = do
modifyIORef visState (\s ->
let newPosition = f $ position s
in s {position = newPosition})
widgetQueueDraw canvas
export :: String -> IO ()
export filename = void $ export' filename
export' :: String -> IO (Maybe String)
export' filename = case mbDrawFn of
Right errorMsg -> do putStrLn errorMsg
return $ Just errorMsg
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
".png" -> Left withPNGSurface
_:".ps" -> Left withPSSurface
_ -> Right "Unknown file extension, try one of the following: .svg, .pdf, .ps, .png"
withPNGSurface filePath width height action =
withImageSurface FormatARGB32 (ceiling width) (ceiling height) $
\surface -> do
ret <- action surface
surfaceWriteToPNG surface filePath
return ret
put :: Signal -> IO ()
put s = void $ timeout signalTimeout $ putMVar visSignal s
mVisMainThread :: IO ()
mVisMainThread = do
initGUI
window <- windowNew
canvas <- drawingAreaNew
widgetModifyBg canvas StateNormal backgroundColor
set window [ windowTitle := title
, containerChild := canvas
]
(uncurry $ windowSetDefaultSize window) defaultSize
onExpose canvas $ const $ do
runCorrect redraw >>= \f -> f canvas
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
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)})
if dragging state
then do
let (oldX, oldY) = mousePos state
(deltaX, deltaY) = (E.eventX e oldX, E.eventY e oldY)
(oldPosX, oldPosY) = position state
modifyIORef visState (\s -> s {position = (oldPosX + deltaX, oldPosY + deltaY)})
widgetQueueDraw canvas
else
runCorrect move >>= \f -> f canvas
return True
onButtonPress canvas $ \e -> do
when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) $
join $ runCorrect click
when (E.eventButton e == RightButton && E.eventClick e == SingleClick) $
modifyIORef visState (\s -> s {dragging = True})
when (E.eventButton e == MiddleButton && E.eventClick e == SingleClick) $ do
modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})
widgetQueueDraw canvas
return True
onButtonRelease canvas $ \e -> do
when (E.eventButton e == RightButton) $
modifyIORef visState (\s -> s {dragging = False})
return True
onScroll canvas $ \e -> do
state <- readIORef visState
when (E.eventDirection e == ScrollUp) $ do
let newZoomRatio = zoomRatio state * zoomIncrement
newPos <- zoomImage canvas state newZoomRatio (mousePos state)
modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})
when (E.eventDirection e == ScrollDown) $ do
let newZoomRatio = zoomRatio state / zoomIncrement
newPos <- zoomImage canvas state newZoomRatio (mousePos state)
modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})
widgetQueueDraw canvas
return True
onKeyPress window $ \e -> do
state <- readIORef visState
when (E.eventKeyName e `elem` ["plus", "Page_Up", "KP_Add"]) $ do
let newZoomRatio = zoomRatio state * zoomIncrement
(oldX, oldY) = position state
newPos = (oldX*zoomIncrement, oldY*zoomIncrement)
modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})
when (E.eventKeyName e `elem` ["minus", "Page_Down", "KP_Subtract"]) $ do
let newZoomRatio = zoomRatio state / zoomIncrement
(oldX, oldY) = position state
newPos = (oldX/zoomIncrement, oldY/zoomIncrement)
modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})
when (E.eventKeyName e `elem` ["0", "equal"]) $
modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})
when (E.eventKeyName e `elem` ["Left", "h", "a"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x + positionIncrement
in s {position = (newX, y)})
when (E.eventKeyName e `elem` ["Right", "l", "d"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x positionIncrement
in s {position = (newX, y)})
when (E.eventKeyName e `elem` ["Up", "k", "w"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y + positionIncrement
in s {position = (x, newY)})
when (E.eventKeyName e `elem` ["Down", "j", "s"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y positionIncrement
in s {position = (x, newY)})
when (E.eventKeyName e `elem` ["H", "A"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x + bigPositionIncrement
in s {position = (newX, y)})
when (E.eventKeyName e `elem` ["L", "D"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x bigPositionIncrement
in s {position = (newX, y)})
when (E.eventKeyName e `elem` ["K", "W"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y + bigPositionIncrement
in s {position = (x, newY)})
when (E.eventKeyName e `elem` ["J", "S"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y bigPositionIncrement
in s {position = (x, newY)})
when (E.eventKeyName e `elem` ["space", "Return", "KP_Enter"]) $
join $ runCorrect click
when (E.eventKeyName e `elem` ["v"]) $
put SwitchSignal
when (E.eventKeyName e `elem` ["c"]) $
put ClearSignal
when (E.eventKeyName e `elem` ["C"]) $
put RestoreSignal
when (E.eventKeyName e `elem` ["u"]) $
put UpdateSignal
when (E.eventKeyName e `elem` ["comma", "bracketleft"]) $
put $ HistorySignal (+1)
when (E.eventKeyName e `elem` ["period", "bracketright"]) $
put $ HistorySignal (\x -> x 1)
widgetQueueDraw canvas
return True
widgetShowAll window
reactThread <- forkIO $ react canvas legendCanvas
onDestroy window (quit reactThread)
mainGUI
return ()
quit :: ThreadId -> IO ()
quit reactThread = do
swapMVar visRunning False
killThread reactThread
#ifdef SDL_WINDOW
react2 :: IO b
react2 = do
mbSignal <- timeout signalTimeout (takeMVar visSignal)
case mbSignal of
Nothing -> do
running <- readMVar visRunning
if running then react2 else
(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
runCorrect updateObjects >>= \f -> f boxes
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: The Graphviz binary (dot) is 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 legendCanvas = do
mbSignal <- timeout signalTimeout (takeMVar visSignal)
case mbSignal of
Nothing -> do
running <- readMVar visRunning
if running then react canvas legendCanvas else
(do swapMVar visRunning True
timeout signalTimeout (putMVar visSignal UpdateSignal)
react canvas legendCanvas)
Just signal -> do
doUpdate <- case signal of
NewSignal x n -> do
modifyMVar_ visBoxes (\y -> return $ if ([n], x) `elem` y then y else y ++ [([n], x)])
return True
ClearSignal -> do
modifyMVar_ visBoxes $ const $ return []
modifyMVar_ visHidden $ const $ return []
modifyMVar_ visHeapHistory $ const $ return (0, [(HeapGraph M.empty, [])])
return False
RestoreSignal -> do
modifyMVar_ visHidden $ const $ return []
return False
RedrawSignal -> return False
UpdateSignal -> return True
SwitchSignal -> doSwitch >> return False
HistorySignal f -> do
modifyMVar_ visHeapHistory (\(i,xs) -> return (max 0 (min (length xs 1) (f i)), xs))
return False
ExportSignal d f -> do
catch (runCorrect exportView >>= \e -> e d f)
(\e -> do let err = show (e :: IOException)
hPutStrLn stderr $ "Couldn't export to file \"" ++ f ++ "\": " ++ err
return ())
return False
boxes <- readMVar visBoxes
when doUpdate $ do
performGC
s <- readIORef visState
x <- multiBuildHeapGraph (heapDepth s) boxes
modifyMVar_ visHeapHistory (\(i,xs) -> return (i,x:xs))
runCorrect updateObjects >>= \f -> f boxes
postGUISync $ widgetQueueDraw canvas
postGUISync $ widgetQueueDraw legendCanvas
react canvas legendCanvas
#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: The Graphviz binary (dot) is not installed"
succN GraphView = ListView
succN ListView = GraphView
#else
where doSwitch = putStrLn "Cannot switch view: Graph view disabled at build"
#endif
runCorrect :: (View -> f) -> IO f
runCorrect f = do
s <- readIORef visState
return $ f $ views !! fromEnum (T.view s)
zoomImage :: WidgetClass w1 => w1 -> State -> Double -> T.Point -> IO T.Point
zoomImage _canvas s newZoomRatio _mousePos@(_x', _y') = do
let (oldPosX, oldPosY) = position s
newZoom = newZoomRatio / zoomRatio s
newPos = (oldPosX * newZoom, oldPosY * newZoom)
return newPos
#ifdef FULL_WINDOW
visMainThread :: IO ()
visMainThread = do
initGUI
builder <- builderNew
builderAddFromFile builder =<< My.getDataFileName "data/main.ui"
let getO :: forall cls . GObjectClass cls
=> (GObject -> cls)
-> String
-> IO cls
getO = builderGetObject builder
window <- getO castToWindow "window"
canvas <- getO castToDrawingArea "drawingarea"
saveDialog <- getO castToFileChooserDialog "savedialog"
aboutDialog <- getO castToAboutDialog "aboutdialog"
depthDialog <- getO castToDialog "depthdialog"
depthSpin <- getO castToSpinButton "depthspin"
legendDialog <- getO castToWindow "legenddialog"
legendCanvas <- getO castToDrawingArea "legenddrawingarea"
newFilter "*.pdf" "PDF" saveDialog
newFilter "*.svg" "SVG" saveDialog
newFilter "*.ps" "PostScript" saveDialog
newFilter "*.png" "PNG" saveDialog
set aboutDialog [aboutDialogVersion := showVersion My.version]
onResponse saveDialog $ fileSave saveDialog
onResponse depthDialog $ setDepthDialog depthDialog depthSpin
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
let setDepthSpin = do
s <- readIORef visState
spinButtonSetValue depthSpin $ fromIntegral $ heapDepth s
getO castToMenuItem "clear" >>= \item -> onActivateLeaf item clear
getO castToMenuItem "switch" >>= \item -> onActivateLeaf item switch
getO castToMenuItem "restore" >>= \item -> onActivateLeaf item restore
getO castToMenuItem "update" >>= \item -> onActivateLeaf item update
getO castToMenuItem "setdepth" >>= \item -> onActivateLeaf item $ setDepthSpin >> widgetShow depthDialog
getO castToMenuItem "export" >>= \item -> onActivateLeaf item $ widgetShow saveDialog
getO castToMenuItem "quit" >>= \item -> onActivateLeaf item $ widgetDestroy window
getO castToMenuItem "about" >>= \item -> onActivateLeaf item $ widgetShow aboutDialog
getO castToMenuItem "legend" >>= \item -> onActivateLeaf item $ widgetShow legendDialog
getO castToMenuItem "timeback" >>= \item -> onActivateLeaf item $ history (+1)
getO castToMenuItem "timeforward" >>= \item -> onActivateLeaf item $ history (\x -> x 1)
getO castToMenuItem "zoomin" >>= \item -> onActivateLeaf item $ zoom canvas (*1.25)
getO castToMenuItem "zoomout" >>= \item -> onActivateLeaf item $ zoom canvas (/1.25)
getO castToMenuItem "left" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x + positionIncrement, y))
getO castToMenuItem "right" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x positionIncrement, y))
getO castToMenuItem "up" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x, y + positionIncrement))
getO castToMenuItem "down" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x, y positionIncrement))
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 errorMsg -> do
errorDialog <- messageDialogNew Nothing [] MessageError ButtonsOk errorMsg
widgetShow errorDialog
onResponse errorDialog $ const $ widgetHide errorDialog
return ()
_ -> return ()
widgetHide fcdialog
setDepthDialog :: Dialog -> SpinButton -> ResponseId -> IO ()
setDepthDialog depthDialog depthSpin response = do
case response of
ResponseOk -> do depth <- spinButtonGetValue depthSpin
setDepth $ round depth
_ -> return ()
widgetHide depthDialog
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)
(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