ghc-vis-0.8: src/GHC/Vis.hs
{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes, OverloadedStrings #-}
{- |
Module : GHC.Vis
Copyright : (c) Dennis Felsing
License : 3-Clause BSD-style
Maintainer : dennis@felsin9.de
Although ghc-vis is meant to be used in GHCi it can also be used as a library
in regular Haskell programs which are run or compiled by GHC. You can run those
programs using \"runghc example.hs\" or \"ghc -threaded example.hs && ./example\".
Without the \"-threaded\"-Flag ghc-vis does not work correctly. This is an
example using ghc-vis outside of GHCi:
> import GHC.Vis
>
> main = do
> putStrLn "Start"
> let a = "teeest"
> let b = [1..3]
> let c = b ++ b
> let d = [1..]
> putStrLn $ show $ d !! 1
>
> visualization
> view a "a"
> view b "b"
> view c "c"
> view d "d"
>
> getChar
> switch
>
> getChar
> putStrLn "End"
-}
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)
import System.IO
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Exception hiding (evaluate)
import Data.Char
import Data.IORef
import Data.Version
import Data.Text ()
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
-- | This is the main function. It's to be called from GHCi and launches a
-- graphical window in a new thread.
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
-- | Evaluate an object that is shown in the visualization. (Names start with 't')
eval :: String -> IO ()
eval t = evaluate t >> update
-- | Switch between the list view and the graph view
switch :: IO ()
switch = put SwitchSignal
-- | When an object is updated by accessing it, you have to call this to
-- refresh the visualization window. You can also click on an object to force
-- an update.
update :: IO ()
update = put UpdateSignal
-- | Clear the visualization window, removing all expressions from it
clear :: IO ()
clear = put ClearSignal
-- | Reset the hidden boxes
restore :: IO ()
restore = put RestoreSignal
-- | Change position in history
history :: (Int -> Int) -> IO ()
history = put . HistorySignal
-- | Set the maximum depth for following closures on the heap
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 the current visualization view to a file, format depends on the
-- file ending. Currently supported: svg, png, pdf, ps
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
on canvas draw $ do
runCorrect redraw >>= \f -> f canvas
runCorrect move >>= \f -> liftIO $ f canvas
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
widgetAddEvents canvas [PointerMotionMask]
on canvas motionNotifyEvent $ do
(x,y) <- eventCoordinates
lift $ do
state <- readIORef visState
modifyIORef visState (\s -> s {mousePos = (x,y)})
if dragging state
then do
let (oldX, oldY) = mousePos state
(deltaX, deltaY) = (x - oldX, y - oldY)
(oldPosX, oldPosY) = position state
modifyIORef visState (\s -> s {position = (oldPosX + deltaX, oldPosY + deltaY)})
widgetQueueDraw canvas
else
runCorrect move >>= \f -> f canvas
return True
on canvas buttonPressEvent $ do
button <- eventButton
eClick <- eventClick
lift $ do
when (button == LeftButton && eClick == SingleClick) $
join $ runCorrect click
when (button == RightButton && eClick == SingleClick) $
modifyIORef visState (\s -> s {dragging = True})
when (button == MiddleButton && eClick == SingleClick) $ do
modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})
widgetQueueDraw canvas
return True
on canvas buttonReleaseEvent $ do
button <- eventButton
lift $ do
when (button == RightButton) $
modifyIORef visState (\s -> s {dragging = False})
return True
on canvas scrollEvent $ do
direction <- eventScrollDirection
lift $ do
state <- readIORef visState
when (direction == ScrollUp) $ do
let newZoomRatio = zoomRatio state * zoomIncrement
newPos <- zoomImage canvas state newZoomRatio (mousePos state)
modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})
when (direction == 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
on window keyPressEvent $ do
eKeyName <- eventKeyName
lift $ do
state <- readIORef visState
when (eKeyName `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 (eKeyName `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 (eKeyName `elem` ["0", "equal"]) $
modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})
when (eKeyName `elem` ["Left", "h", "a"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x + positionIncrement
in s {position = (newX, y)})
when (eKeyName `elem` ["Right", "l", "d"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x - positionIncrement
in s {position = (newX, y)})
when (eKeyName `elem` ["Up", "k", "w"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y + positionIncrement
in s {position = (x, newY)})
when (eKeyName `elem` ["Down", "j", "s"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y - positionIncrement
in s {position = (x, newY)})
when (eKeyName `elem` ["H", "A"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x + bigPositionIncrement
in s {position = (newX, y)})
when (eKeyName `elem` ["L", "D"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newX = x - bigPositionIncrement
in s {position = (newX, y)})
when (eKeyName `elem` ["K", "W"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y + bigPositionIncrement
in s {position = (x, newY)})
when (eKeyName `elem` ["J", "S"]) $
modifyIORef visState (\s ->
let (x,y) = position s
newY = y - bigPositionIncrement
in s {position = (x, newY)})
when (eKeyName `elem` ["space", "Return", "KP_Enter"]) $
join $ runCorrect click
when (eKeyName `elem` ["v"]) $
put SwitchSignal
when (eKeyName `elem` ["c"]) $
put ClearSignal
when (eKeyName `elem` ["C"]) $
put RestoreSignal
when (eKeyName `elem` ["u"]) $
put UpdateSignal
when (eKeyName `elem` ["comma", "bracketleft"]) $
put $ HistorySignal (+1)
when (eKeyName `elem` ["period", "bracketright"]) $
put $ HistorySignal (\x -> x - 1)
widgetQueueDraw canvas
return True
widgetShowAll window
reactThread <- forkIO $ react canvas legendCanvas
--onDestroy window mainQuit -- Causes :r problems with multiple windows
on window destroyEvent $ lift $ quit reactThread >> return True
mainGUI
return ()
quit :: ThreadId -> IO ()
quit reactThread = do
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 -- 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: 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
-- 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 react canvas legendCanvas else
-- :r caused visRunning to be reset
(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 -- 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 ]
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 :: MonadIO m => (View -> f) -> m f
runCorrect f = do
s <- liftIO $ 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]
on saveDialog response $ fileSave saveDialog
on depthDialog response $ setDepthDialog depthDialog depthSpin
on aboutDialog response $ const $ widgetHide aboutDialog
on saveDialog deleteEvent $ lift $ widgetHide saveDialog >> return True
on aboutDialog deleteEvent $ lift $ widgetHide aboutDialog >> return True
on legendDialog deleteEvent $ lift $ widgetHide legendDialog >> return True
let setDepthSpin = do
s <- readIORef visState
spinButtonSetValue depthSpin $ fromIntegral $ heapDepth s
getO castToMenuItem "clear" >>= \item -> on item menuItemActivated clear
getO castToMenuItem "switch" >>= \item -> on item menuItemActivated switch
getO castToMenuItem "restore" >>= \item -> on item menuItemActivated restore
getO castToMenuItem "update" >>= \item -> on item menuItemActivated update
getO castToMenuItem "setdepth" >>= \item -> on item menuItemActivated $ setDepthSpin >> widgetShow depthDialog
getO castToMenuItem "export" >>= \item -> on item menuItemActivated $ widgetShow saveDialog
getO castToMenuItem "quit" >>= \item -> on item menuItemActivated $ widgetDestroy window
getO castToMenuItem "about" >>= \item -> on item menuItemActivated $ widgetShow aboutDialog
getO castToMenuItem "legend" >>= \item -> on item menuItemActivated $ widgetShow legendDialog
getO castToMenuItem "timeback" >>= \item -> on item menuItemActivated $ history (+1)
getO castToMenuItem "timeforward" >>= \item -> on item menuItemActivated $ history (\x -> x - 1)
getO castToMenuItem "zoomin" >>= \item -> on item menuItemActivated $ zoom canvas (*1.25)
getO castToMenuItem "zoomout" >>= \item -> on item menuItemActivated $ zoom canvas (/1.25)
getO castToMenuItem "left" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x + positionIncrement, y))
getO castToMenuItem "right" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x - positionIncrement, y))
getO castToMenuItem "up" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x, y + positionIncrement))
getO castToMenuItem "down" >>= \item -> on item menuItemActivated $ 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
on canvas draw $ do
boxes <- liftIO $ readMVar visBoxes
if null boxes
then renderSVGScaled canvas welcomeSVG
else do
runCorrect redraw >>= \f -> f canvas
runCorrect move >>= \f -> liftIO $ f canvas
return ()
on legendCanvas draw $ do
state <- liftIO $ readIORef visState
renderSVGScaled legendCanvas $ case T.view state of
ListView -> legendListSVG
GraphView -> legendGraphSVG
setupGUI window canvas legendCanvas
fileSave :: FileChooserDialog -> ResponseId -> IO ()
fileSave fcdialog responseId = do
case responseId 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
on errorDialog response $ const $ widgetHide errorDialog
return ()
_ -> return ()
widgetHide fcdialog
setDepthDialog :: Dialog -> SpinButton -> ResponseId -> IO ()
setDepthDialog depthDialog depthSpin responseId = do
case responseId 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 -> Render ()
renderSVGScaled canvas svg = do
rw2 <- liftIO $ widgetGetAllocatedWidth canvas
rh2 <- liftIO $ widgetGetAllocatedHeight canvas
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
return ()
#endif
-- Zoom into mouse, but only working from (0,0)
-- newPos = ( oldPosX + x * zoomRatio s - x * newZoomRatio
-- , oldPosY + y * zoomRatio s - y * newZoomRatio )
-- Zoom into center:
-- newPos = ( oldPosX * zoomIncrement
-- , oldPosY * zoomIncrement )