module GHC.Vis.GTK.Graph (
export,
redraw,
click,
move,
updateObjects
)
where
import Graphics.UI.Gtk hiding (Box, Signal, Rectangle)
import qualified Graphics.UI.Gtk as Gtk
import Graphics.Rendering.Cairo
import Control.Concurrent
import Control.Monad
import Data.IORef
import System.IO.Unsafe
import GHC.Vis.Graph
import GHC.Vis.Types hiding (State)
import GHC.Vis.GTK.Common
import GHC.HeapView hiding (size)
import Graphics.XDot.Viewer
import Graphics.XDot.Types hiding (size, w, h)
data State = State
{ boxes :: [Box]
, operations :: [(Maybe Int, Operation)]
, totalSize :: (Double, Double, Double, Double)
, bounds :: [(Int, (Double, Double, Double, Double))]
, hover :: Maybe Int
}
state :: IORef State
state = unsafePerformIO $ newIORef $ State [] [] (0, 0, 1, 1) [] Nothing
redraw :: WidgetClass w => w -> IO ()
redraw canvas = do
s <- readIORef state
Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas
boundingBoxes <- render canvas (draw s rw2 rh2)
modifyIORef state (\s' -> s' {bounds = boundingBoxes})
export :: String -> IO ()
export file = do
s <- readIORef state
let (_, _, xSize, ySize) = totalSize s
withSVGSurface file xSize ySize
(\surface -> renderWith surface (draw s (round xSize) (round ySize)))
return ()
draw :: State -> Int -> Int -> Render [(Int, Rectangle)]
draw s rw2 rh2 = do
let rw = 0.97 * fromIntegral rw2
rh = 0.97 * fromIntegral rh2
ops = operations s
size@(_,_,sw,sh) = totalSize s
sx = min (rw / sw) (rh / sh)
sy = sx
ox = 0.5 * fromIntegral rw2
oy = 0.5 * fromIntegral rh2
translate ox oy
scale sx sy
result <- drawAll (hover s) size ops
return $ map (\(o, (x,y,w,h)) -> (o,
( x * sx + ox
, y * sy + oy
, w * sx
, h * sy
))) result
render :: WidgetClass w => w -> Render b -> IO b
render canvas r = do
win <- widgetGetDrawWindow canvas
renderWithDrawable win r
click :: IO ()
click = do
s <- readIORef state
case hover s of
Just t -> do
evaluate2 $ boxes s !! t
putMVar visSignal UpdateSignal
_ -> return ()
evaluate2 :: Box -> IO ()
evaluate2 b@(Box a) = do
c <- getBoxedClosureData b
case c of
IndClosure{} -> a `seq` return ()
BlackholeClosure{} -> a `seq` return ()
FunClosure{} -> a `seq` return ()
ThunkClosure{} -> a `seq` return ()
APClosure{} -> a `seq` return ()
PAPClosure{} -> a `seq` return ()
_ -> return ()
move :: WidgetClass w => w -> IO ()
move canvas = do
vs <- readIORef visState
oldS <- readIORef state
let oldHover = hover oldS
modifyIORef state $ \s' -> (
let (mx, my) = mousePos vs
check (o, (x,y,w,h)) =
if x <= mx && mx <= x + w &&
y <= my && my <= y + h
then Just o else Nothing
in s' {hover = msum $ map check (bounds oldS)}
)
s <- readIORef state
unless (oldHover == hover s) $ widgetQueueDraw canvas
updateObjects :: [(Box, String)] -> IO ()
updateObjects bs = do
(ops, bs', size) <- xDotParse bs
modifyIORef state (\s -> s {operations = ops, boxes = bs', totalSize = size})