content: {-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes, OverloadedStrings #-}
  {- |
     Module      : GHC.Vis
     Copyright   : (c) Dennis Felsing
     License     : 3-Clause BSD-style
     Maintainer  : dennis@felsing.org
  
  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 :: Maybe String)
  
    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 -> Double -> Double -> (Surface -> IO a) -> IO a
          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 :: View -> (forall a. FilePath -> Double -> Double -> (Surface -> IO a) -> IO a) -> String -> IO ()) >>= \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 )
  