module GHC.Vis.GTK.List (
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.Internal
import GHC.Vis.Types hiding (State)
import GHC.Vis.GTK.Common
import GHC.HeapView (Box)
type Rectangle = (Double, Double, Double, Double)
data State = State
{ objects :: [[VisObject]]
, bounds :: [(String, Rectangle)]
, hover :: Maybe String
}
type RGB = (Double, Double, Double)
state :: IORef State
state = unsafePerformIO $ newIORef $ State [] [] Nothing
fontName :: String
fontName = "DejaVu Sans"
fontSize :: Double
fontSize = 15
colorName :: RGB
colorName = (0.5,1,0.5)
colorNameHighlighted :: RGB
colorNameHighlighted = (0,1,0)
colorLink :: RGB
colorLink = (0.5,0.5,1)
colorLinkHighlighted :: RGB
colorLinkHighlighted = (0.25,0.25,1)
colorFunction :: RGB
colorFunction = (1,0.5,0.5)
colorFunctionHighlighted :: RGB
colorFunctionHighlighted = (1,0,0)
padding :: Double
padding = 5
redraw :: WidgetClass w => w -> IO ()
redraw canvas = do
boxes <- readMVar visBoxes
s <- readIORef state
Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas
boundingBoxes <- render canvas (draw s rw2 rh2 boxes)
modifyIORef state (\s' -> s' {bounds = boundingBoxes})
export :: String -> IO ()
export file = do
boxes <- readMVar visBoxes
s <- readIORef state
withSVGSurface file (fromIntegral xSize) (fromIntegral ySize)
(\surface -> renderWith surface (draw s xSize ySize boxes))
return ()
where xSize = 500 :: Int
ySize = 500 :: Int
draw :: State -> Int -> Int -> [(a, String)] -> Render [(String, Rectangle)]
draw s rw2 rh2 boxes = do
let objs = objects s
names = map ((++ ": ") . snd) boxes
nameWidths <- mapM (width . Unnamed) names
pos <- mapM height objs
widths <- mapM (mapM width) objs
let rw = 0.97 * fromIntegral rw2
rh = 0.99 * fromIntegral rh2
maxNameWidth = maximum nameWidths
widths2 = 1 : map (\ws -> maxNameWidth + sum ws) widths
sw = maximum widths2
sh = sum (map (+ 30) pos) 15
sx = min (rw / sw) (rh / sh)
sy = sx
ox = 0
oy = 0
translate ox oy
scale sx sy
let rpos = scanl (\a b -> a + b + 30) 30 pos
result <- mapM (drawEntry s maxNameWidth) (zip3 objs rpos names)
return $ map (\(o, (x,y,w,h)) -> (o, (x*sx+ox,y*sy+oy,w*sx,h*sy))) $ concat result
render :: WidgetClass w => w -> Render b -> IO b
render canvas r = do
win <- widgetGetDrawWindow canvas
renderWithDrawable win $ do
selectFontFace fontName FontSlantNormal FontWeightNormal
setFontSize fontSize
r
click :: IO ()
click = do
s <- readIORef state
case hover s of
Just t -> do
evaluate t
putMVar visSignal UpdateSignal
_ -> 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 s')}
)
s <- readIORef state
unless (oldHover == hover s) $ widgetQueueDraw canvas
updateObjects :: [(Box, String)] -> IO ()
updateObjects boxes = do
objs <- parseBoxes boxes
modifyIORef state (\s -> s {objects = objs})
drawEntry :: State -> Double -> ([VisObject], Double, String) -> Render [(String, Rectangle)]
drawEntry s nameWidth (obj, pos, name) = do
save
translate 0 pos
moveTo 0 0
drawBox s $ Unnamed name
translate nameWidth 0
moveTo 0 0
boundingBoxes <- mapM (drawBox s) obj
restore
return $ map (\(o, (x,y,w,h)) -> (o, (x+nameWidth,y+pos,w,h))) $ concat boundingBoxes
drawBox :: State -> VisObject -> Render [(String, Rectangle)]
drawBox _ o@(Unnamed content) = do
(x,_) <- getCurrentPoint
wc <- width o
moveTo (x + padding/2) 0
setSourceRGB 0 0 0
showText content
moveTo (x + wc) 0
return []
drawBox s o@(Function target) =
drawFunctionLink s o target colorFunction colorFunctionHighlighted
drawBox s o@(Link target) =
drawFunctionLink s o target colorLink colorLinkHighlighted
drawBox s o@(Named name content) = do
(x,_) <- getCurrentPoint
TextExtents xb _ _ _ xa _ <- textExtents name
FontExtents fa _ fh _ _ <- fontExtents
hc <- height content
wc <- width o
let (ux, uy, uw, uh) =
( x
, fa padding
, wc
, fh + 10 + hc
)
setLineCap LineCapRound
roundedRect ux uy uw uh
setColor s name colorName colorNameHighlighted
fillAndSurround
moveTo ux (hc + 5 fa padding)
lineTo (ux + uw) (hc + 5 fa padding)
stroke
save
moveTo (x + padding) 0
bb <- mapM (drawBox s) content
restore
moveTo (x + uw/2 (xa xb)/2) (hc + 7.5 padding)
showText name
moveTo (x + wc) 0
return $ concat bb ++ [(name, (ux, uy, uw, uh))]
drawFunctionLink :: State -> VisObject -> String -> RGB -> RGB -> Render [(String, Rectangle)]
drawFunctionLink s o target color1 color2 = do
(x,_) <- getCurrentPoint
FontExtents fa _ fh _ _ <- fontExtents
wc <- width o
let (ux, uy, uw, uh) =
( x
, (fa) padding
, wc
, fh + 10
)
setLineCap LineCapRound
roundedRect ux uy uw uh
setColor s target color1 color2
fillAndSurround
moveTo (x + padding) 0
showText target
moveTo (x + wc) 0
return [(target, (ux, uy, uw, uh))]
setColor :: State -> String -> RGB -> RGB -> Render ()
setColor s name (r,g,b) (r',g',b') = case hover s of
Just t -> if t == name then setSourceRGB r' g' b'
else setSourceRGB r g b
_ -> setSourceRGB r g b
fillAndSurround :: Render ()
fillAndSurround = do
fillPreserve
setSourceRGB 0 0 0
stroke
roundedRect :: Double -> Double -> Double -> Double -> Render ()
roundedRect x y w h = do
moveTo x (y + pad)
lineTo x (y + h pad)
arcNegative (x + pad) (y + h pad) pad pi (pi/2)
lineTo (x + w pad) (y + h)
arcNegative (x + w pad) (y + h pad) pad (pi/2) 0
lineTo (x + w) (y + pad)
arcNegative (x + w pad) (y + pad) pad 0 (pi/2)
lineTo (x + pad) y
arcNegative (x + pad) (y + pad) pad (pi/2) (pi)
closePath
where pad = 1/10 * min w h
height :: [VisObject] -> Render Double
height xs = do
FontExtents _ _ fh _ _ <- fontExtents
let go (Named _ ys) = (fh + 15) + maximum (map go ys)
go (Unnamed _) = fh
go (Link _) = fh + 10
go (Function _) = fh + 10
return $ maximum $ map go xs
width :: VisObject -> Render Double
width (Named x ys) = do
TextExtents xb _ _ _ xa _ <- textExtents x
w2s <- mapM width ys
return $ max (xa xb) (sum w2s) + 10
width (Unnamed x) = do
TextExtents xb _ _ _ xa _ <- textExtents x
return $ xa xb + 5
width (Link x) = do
TextExtents xb _ _ _ xa _ <- textExtents x
return $ xa xb + 10
width (Function x) = do
TextExtents xb _ _ _ xa _ <- textExtents x
return $ xa xb + 10