{-# LANGUAGE CPP, ExistentialQuantification, TupleSections, NamedFieldPuns
           , ViewPatterns, ScopedTypeVariables #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-- |
-- Module      :  Yi.UI.Pango
-- Copyright   :  (c) 2007, 2008 Jean-Philippe Bernardy
-- License     :  GPL
--
-- This module defines a user interface implemented using gtk2hs and
-- pango for direct text rendering.

module Yi.UI.Pango (start) where

import Prelude hiding (error, elem, mapM_, foldl, concat, mapM)
import Control.Exception (catch, SomeException)
import Control.Concurrent
import Control.Monad hiding (forM_, mapM_, forM, mapM)
import Control.Applicative
import Control.Lens hiding (set, Action, from)
import Data.Prototype
import Data.IORef
import Data.List (intercalate)
import qualified Data.List.PointedList as PL (moveTo)
import qualified Data.List.PointedList.Circular as PL
import Data.Maybe
import Data.Foldable
import Data.Traversable
import qualified Data.Map as M
import qualified Data.Rope as Rope

import Graphics.UI.Gtk hiding (Region, Window, Action , Point,
                               Style, Modifier, on)
import Graphics.UI.Gtk.Gdk.GC hiding (foreground)
import qualified Graphics.UI.Gtk.Gdk.EventM as EventM
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.Gdk.GC as Gtk
import System.Glib.GError

import Yi.Buffer
import Yi.Config
import Yi.Editor
import Yi.Event
import Yi.Keymap
import Yi.Layout(DividerPosition, DividerRef)
import Yi.Style
import Yi.Tab
import Yi.Window
import Yi.Utils
import Yi.Monad
import Yi.Debug

import qualified Yi.UI.Common as Common
import Yi.UI.Pango.Layouts
import Yi.UI.Pango.Utils
import Yi.UI.Pango.Control (keyTable)
import Yi.UI.TabBar
import Yi.UI.Utils

#ifdef GNOME_ENABLED
import Yi.UI.Pango.Gnome(watchSystemFont)
#endif

-- We use IORefs in all of these datatypes for all fields which could
-- possibly change over time.  This ensures that no 'UI', 'TabInfo',
-- 'WinInfo' will ever go out of date.

data UI = UI
    { uiWindow    :: Gtk.Window
    , uiNotebook  :: SimpleNotebook
    , uiStatusbar :: Statusbar
    , tabCache    :: IORef TabCache
    , uiActionCh  :: Action -> IO ()
    , uiConfig    :: UIConfig
    , uiFont      :: IORef FontDescription
    , uiInput     :: IMContext
    }

type TabCache = PL.PointedList TabInfo

-- We don't need to know the order of the windows (the layout manages
-- that) so we might as well use a map
type WindowCache = M.Map WindowRef WinInfo

data TabInfo = TabInfo
    { coreTabKey      :: TabRef
    , layoutDisplay   :: LayoutDisplay
    , miniwindowPage  :: MiniwindowDisplay
    , tabWidget       :: Widget
    , windowCache     :: IORef WindowCache
    , fullTitle       :: IORef String
    , abbrevTitle     :: IORef String
    }

instance Show TabInfo where
    show t = show (coreTabKey t)

data WinInfo = WinInfo
    { coreWinKey      :: WindowRef
    , coreWin         :: IORef Window
    , shownTos        :: IORef Point
    , lButtonPressed  :: IORef Bool
    , insertingMode   :: IORef Bool
    , inFocus         :: IORef Bool
    , winLayoutInfo   :: MVar WinLayoutInfo
    , winMetrics      :: FontMetrics
    , textview        :: DrawingArea
    , modeline        :: Label
    , winWidget       :: Widget -- ^ Top-level widget for this window.
    }

data WinLayoutInfo = WinLayoutInfo {
   winLayout :: !PangoLayout,
   tos :: !Point,
   bos :: !Point,
   bufEnd :: !Point,
   cur :: !Point,
   buffer :: !FBuffer,
   regex :: !(Maybe SearchExp)
 }

instance Show WinInfo where
    show w = show (coreWinKey w)

instance Ord EventM.Modifier where
  x <= y = fromEnum x <= fromEnum y

mkUI :: UI -> Common.UI
mkUI ui = Common.dummyUI
    { Common.main          = main
    , Common.end           = const end
    , Common.suspend       = windowIconify (uiWindow ui)
    , Common.refresh       = refresh ui
    , Common.layout        = doLayout ui
    , Common.reloadProject = const reloadProject
    }

updateFont :: UIConfig -> IORef FontDescription -> IORef TabCache -> Statusbar
                  -> FontDescription -> IO ()
updateFont cfg fontRef tc status font = do
    maybe (return ()) (fontDescriptionSetFamily font) (configFontName cfg)
    maybe (return ()) (fontDescriptionSetSize font . fromIntegral)
      (configFontSize cfg)

    writeIORef fontRef font
    widgetModifyFont status (Just font)
    tcs <- readIORef tc
    forM_ tcs $ \tabinfo -> do
      wcs <- readIORef (windowCache tabinfo)
      forM_ wcs $ \wininfo -> do
        withMVar (winLayoutInfo wininfo) $ \WinLayoutInfo{winLayout} ->
          layoutSetFontDescription winLayout (Just font)

        -- This will cause the textview to redraw
        widgetModifyFont (textview wininfo) (Just font)
        widgetModifyFont (modeline wininfo) (Just font)

askBuffer :: Window -> FBuffer -> BufferM a -> a
askBuffer w b f = fst $ runBuffer w b f

-- | Initialise the ui
start :: UIBoot
start cfg ch outCh ed =
  catch (startNoMsg cfg ch outCh ed)
  (\(GError _dom _code msg) -> fail msg)

startNoMsg :: UIBoot
startNoMsg cfg ch outCh ed = do
  logPutStrLn "startNoMsg"
  void unsafeInitGUIForThreadedRTS

  win   <- windowNew
  ico   <- loadIcon "yi+lambda-fat-32.png"
  vb    <- vBoxNew False 1    -- Top-level vbox

  im <- imMulticontextNew
  imContextSetUsePreedit im False  -- handler for preedit string not implemented

  -- Yi.Buffer.Misc.insertN for atomic input?
  im `on` imContextCommit $ mapM_ (\k -> ch $ Event (KASCII k) [])

  set win [ windowDefaultWidth  := 700
          , windowDefaultHeight := 900
          , windowTitle         := "Yi"
          , windowIcon          := Just ico
          , containerChild      := vb
          ]
  win `on` deleteEvent $ io $ mainQuit >> return True
  win `on` keyPressEvent $ handleKeypress ch im

  paned <- hPanedNew
  tabs <- simpleNotebookNew
  panedAdd2 paned (baseWidget tabs)

  status  <- statusbarNew
  -- statusbarGetContextId status "global"

  set vb [ containerChild := paned
         , containerChild := status
         , boxChildPacking status := PackNatural
         ]

  fontRef <- newIORef undefined

  let actionCh = outCh . singleton
  tc <- newIORef =<< newCache ed actionCh

#ifdef GNOME_ENABLED
  let watchFont = watchSystemFont
#else
  let watchFont = (fontDescriptionFromString "Monospace 10" >>=)
#endif
  watchFont $ updateFont (configUI cfg) fontRef tc status

  -- use our magic threads thingy
  -- http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/
  void $ timeoutAddFull (yield >> return True) priorityDefaultIdle 50

  widgetShowAll win

  let ui = UI win tabs status tc actionCh (configUI cfg) fontRef im

  -- Keep the current tab focus up to date
  let move n pl = fromMaybe pl (PL.moveTo n pl)
      runAction = uiActionCh ui . makeAction
  -- why does this cause a hang without postGUIAsync?
  simpleNotebookOnSwitchPage (uiNotebook ui) $ \n -> postGUIAsync $
    runAction ((%=) tabsA (move n) :: EditorM ())

  return (mkUI ui)


main :: IO ()
main = logPutStrLn "GTK main loop running" >> mainGUI

-- | Clean up and go home
end :: IO ()
end = mainQuit

-- | Modify GUI and the 'TabCache' to reflect information in 'Editor'.
updateCache :: UI -> Editor -> IO ()
updateCache ui e = do
       cache <- readRef $ tabCache ui
       -- convert to a map for convenient lookups
       let cacheMap = mapFromFoldable . fmap (\t -> (coreTabKey t, t)) $ cache

       -- build the new cache
       cache' <- forM (e ^. tabsA) $ \tab ->
         case M.lookup (tkey tab) cacheMap of
           Just t -> updateTabInfo e ui tab t >> return t
           Nothing -> newTab e ui tab

       -- store the new cache
       writeRef (tabCache ui) cache'

       -- update the GUI
       simpleNotebookSet (uiNotebook ui)
         =<< forM cache' (\t -> (tabWidget t,) <$> readIORef (abbrevTitle t))


-- | Modify GUI and given 'TabInfo' to reflect information in 'Tab'.
updateTabInfo :: Editor -> UI -> Tab -> TabInfo -> IO ()
updateTabInfo e ui tab tabInfo = do
    -- update the window cache
    wCacheOld <- readIORef (windowCache tabInfo)
    wCacheNew <- mapFromFoldable <$> forM (tab ^. tabWindowsA) (\w ->
      case M.lookup (wkey w) wCacheOld of
        Just wInfo -> updateWindow e ui w wInfo >> return (wkey w, wInfo)
        Nothing -> (wkey w,) <$> newWindow e ui w)
    writeIORef (windowCache tabInfo) wCacheNew

    -- TODO update renderer, etc?

    let lookupWin w = wCacheNew M.! w

    -- set layout
    layoutDisplaySet (layoutDisplay tabInfo)
      . fmap (winWidget . lookupWin) . tabLayout $ tab

    -- set minibox
    miniwindowDisplaySet (miniwindowPage tabInfo)
      . fmap (winWidget . lookupWin . wkey) . tabMiniWindows $ tab

    -- set focus
    setWindowFocus e ui tabInfo . lookupWin . wkey . tabFocus $ tab

updateWindow :: Editor -> UI -> Window -> WinInfo -> IO ()
updateWindow e _ui win wInfo = do
    writeIORef (inFocus wInfo) False -- see also 'setWindowFocus'
    writeIORef (coreWin wInfo) win
    writeIORef (insertingMode wInfo) (askBuffer win (findBufferWith (bufkey win) e) $ use insertingA)

setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()
setWindowFocus e ui t w = do
  win <- readIORef (coreWin w)
  let bufferName = shortIdentString (commonNamePrefix e) $
                   findBufferWith (bufkey win) e
      ml = askBuffer win (findBufferWith (bufkey win) e) $
           getModeLine (commonNamePrefix e)
      im = uiInput ui

  writeIORef (inFocus w) True -- see also 'updateWindow'
  update (textview w) widgetIsFocus True
  update (modeline w) labelText ml
  writeIORef (fullTitle t) bufferName
  writeIORef (abbrevTitle t) (tabAbbrevTitle bufferName)
  drawW <- catch (fmap Just $ widgetGetDrawWindow $ textview w)
                 (\(_ :: SomeException) -> return Nothing)
  imContextSetClientWindow im drawW
  imContextFocusIn im

getWinInfo :: UI -> WindowRef -> IO WinInfo
getWinInfo ui ref =
  let tabLoop []     = error "Yi.UI.Pango.getWinInfo: window not found"
      tabLoop (t:ts) = do
        wCache <- readIORef (windowCache t)
        case M.lookup ref wCache of
          Just w -> return w
          Nothing -> tabLoop ts
  in readIORef (tabCache ui) >>= (tabLoop . toList)

-- | Make the cache from the editor and the action channel
newCache :: Editor -> (Action -> IO ()) -> IO TabCache
newCache e actionCh = mapM (mkDummyTab actionCh) (e ^. tabsA)

-- | Make a new tab, and populate it
newTab :: Editor -> UI -> Tab -> IO TabInfo
newTab e ui tab = do
  t <- mkDummyTab (uiActionCh ui) tab
  updateTabInfo e ui tab t
  return t

-- | Make a minimal new tab, without any windows.
-- This is just for bootstrapping the UI; 'newTab' should normally
-- be called instead.
mkDummyTab :: (Action -> IO ()) -> Tab -> IO TabInfo
mkDummyTab actionCh tab = do
    ws <- newIORef M.empty
    ld <- layoutDisplayNew
    layoutDisplayOnDividerMove ld (handleDividerMove actionCh)
    mwp <- miniwindowDisplayNew
    tw <- vBoxNew False 0
    set tw [containerChild := baseWidget ld,
            containerChild := baseWidget mwp,
            boxChildPacking (baseWidget ld) := PackGrow,
            boxChildPacking (baseWidget mwp) := PackNatural]
    ftRef <- newIORef ""
    atRef <- newIORef ""
    return (TabInfo (tkey tab) ld mwp (toWidget tw) ws ftRef atRef)


-- | Make a new window.
newWindow :: Editor -> UI -> Window -> IO WinInfo
newWindow e ui w = do
    let b = findBufferWith (bufkey w) e
    f <- readIORef (uiFont ui)

    ml <- labelNew Nothing
    widgetModifyFont ml (Just f)
    set ml [ miscXalign := 0.01 ] -- so the text is left-justified.

    -- allow the modeline to be covered up, horizontally
    widgetSetSizeRequest ml 0 (-1)

    v <- drawingAreaNew
    widgetModifyFont v (Just f)
    widgetAddEvents v [Button1MotionMask]
    widgetModifyBg v StateNormal . mkCol False . Yi.Style.background
      . baseAttributes . configStyle $ uiConfig ui

    sw <- scrolledWindowNew Nothing Nothing
    scrolledWindowAddWithViewport sw v
    scrolledWindowSetPolicy sw PolicyAutomatic PolicyNever

    box <- if isMini w
     then do
      prompt <- labelNew (Just $ miniIdentString b)
      widgetModifyFont prompt (Just f)

      hb <- hBoxNew False 1
      set hb [ containerChild := prompt,
               containerChild := sw,
               boxChildPacking prompt := PackNatural,
               boxChildPacking sw := PackGrow]

      return (castToBox hb)
     else do
      vb <- vBoxNew False 1
      set vb [ containerChild := sw,
               containerChild := ml,
               boxChildPacking ml := PackNatural]
      return (castToBox vb)

    tosRef    <- newIORef (askBuffer w b (getMarkPointB
                                          =<< fromMark <$> askMarks))
    context   <- widgetCreatePangoContext v
    layout    <- layoutEmpty context
    layoutRef <- newMVar (WinLayoutInfo layout 0 0 0 0
                          (findBufferWith (bufkey w) e) Nothing)
    language  <- contextGetLanguage context
    metrics   <- contextGetMetrics context f language
    ifLButton <- newIORef False
    imode     <- newIORef False
    focused   <- newIORef False
    winRef    <- newIORef w

    layoutSetFontDescription layout (Just f)

    -- stops layoutGetText crashing (as of gtk2hs 0.10.1)
    layoutSetText layout ""

    let ref = wkey w
        win = WinInfo { coreWinKey = ref
                      , coreWin   = winRef
                      , winLayoutInfo = layoutRef
                      , winMetrics = metrics
                      , textview  = v
                      , modeline  = ml
                      , winWidget = toWidget box
                      , shownTos  = tosRef
                      , lButtonPressed = ifLButton
                      , insertingMode = imode
                      , inFocus = focused
                      }
    updateWindow e ui w win

    v `on` buttonPressEvent   $ handleButtonClick   ui ref
    v `on` buttonReleaseEvent $ handleButtonRelease ui win
    v `on` scrollEvent        $ handleScroll        ui win

    -- todo: allocate event rather than configure?
    v `on` configureEvent     $ handleConfigure     ui

    v `on` motionNotifyEvent  $ handleMove          ui win
    void $ v `onExpose` render ui win
    -- also redraw when the window receives/loses focus
    uiWindow ui `on` focusInEvent $ io (widgetQueueDraw v) >> return False
    uiWindow ui `on` focusOutEvent $ io (widgetQueueDraw v) >> return False
    -- todo: consider adding an 'isDirty' flag to WinLayoutInfo,
    -- so that we don't have to recompute the Attributes when focus changes.
    return win

refresh :: UI -> Editor -> IO ()
refresh ui e = do
    postGUIAsync $ do
       contextId <- statusbarGetContextId (uiStatusbar ui) "global"
       statusbarPop  (uiStatusbar ui) contextId
       void $ statusbarPush (uiStatusbar ui) contextId $ intercalate "  " $
         statusLine e

    updateCache ui e -- The cursor may have changed since doLayout
    cache <- readRef $ tabCache ui
    forM_ cache $ \t -> do
        wCache <- readIORef (windowCache t)
        forM_ wCache $ \w -> do
            updateWinInfoForRendering e ui w
            widgetQueueDraw (textview w)

-- | Record all the information we need for rendering.
--
-- This information is kept in an MVar so that the PangoLayout and
-- tos/bos/buffer are in sync.
updateWinInfoForRendering :: Editor -> UI -> WinInfo -> IO ()
updateWinInfoForRendering e _ui w = modifyMVar_ (winLayoutInfo w) $ \wli -> do
  win <- readIORef (coreWin w)
  return $! wli{buffer=findBufferWith (bufkey win) e,regex=currentRegex e}

-- | Tell the 'PangoLayout' what colours to draw, and draw the 'PangoLayout'
-- and the cursor onto the screen
render :: UI -> WinInfo -> t -> IO Bool
render ui w _event =
  withMVar (winLayoutInfo w) $
  \WinLayoutInfo{winLayout=layout,tos,bos,cur,buffer=b,regex} -> do
    -- read the information
    win <- readIORef (coreWin w)

    -- add color attributes.
    let picture = askBuffer win b $ attributesPictureAndSelB sty regex
                  (mkRegion tos bos)
        sty = extractValue $ configTheme (uiConfig ui)

        picZip = zip picture $ drop 1 (fst <$> picture) ++ [bos]
        strokes = [ (start',s,end') | ((start', s), end') <- picZip
                                    , s /= emptyAttributes ]

        rel p = fromIntegral (p - tos)
        allAttrs = concat $ do
          (p1, Attributes fg bg _rv bd itlc udrl, p2) <- strokes
          let atr x = x (rel p1) (rel p2)
              if' p x y = if p then x else y
          return [ atr AttrForeground $ mkCol True fg
                 , atr AttrBackground $ mkCol False bg
                 , atr AttrStyle $ if' itlc StyleItalic StyleNormal
                 , atr AttrUnderline $ if' udrl UnderlineSingle UnderlineNone
                 , atr AttrWeight $ if' bd WeightBold WeightNormal
                 ]

    layoutSetAttributes layout allAttrs

    drawWindow <- widgetGetDrawWindow $ textview w
    gc <- gcNew drawWindow

    -- see Note [PangoLayout width]
    -- draw the layout
    drawLayout drawWindow gc 1 0 layout

    -- calculate the cursor position
    im <- readIORef (insertingMode w)

    -- check focus, and decide whether we want a wide cursor
    bufferFocused <- readIORef (inFocus w)
    uiFocused <- Gtk.windowHasToplevelFocus (uiWindow ui)
    let focused = bufferFocused && uiFocused
        wideCursor =
         case configCursorStyle (uiConfig ui) of
           AlwaysFat -> True
           NeverFat -> False
           FatWhenFocused -> focused
           FatWhenFocusedAndInserting -> focused && im


    (PangoRectangle (succ -> curX) curY curW curH, _) <-
      layoutGetCursorPos layout (rel cur)
    -- tell the input method
    imContextSetCursorLocation (uiInput ui) $
      Rectangle (round curX) (round curY) (round curW) (round curH)
    -- paint the cursor
    gcSetValues gc
      (newGCValues { Gtk.foreground = mkCol True . Yi.Style.foreground
                                      . baseAttributes . configStyle $
                                      uiConfig ui
                   , Gtk.lineWidth = if wideCursor then 2 else 1 })

    -- tell the renderer
    if im
      then  -- if we are inserting, we just want a line
      drawLine drawWindow gc (round curX, round curY)
      (round $ curX + curW, round $ curY + curH)

      -- we aren't inserting, we want a rectangle around the current character
      else do
      PangoRectangle (succ -> chx) chy chw chh <- layoutIndexToPos
                                                  layout (rel cur)
      drawRectangle drawWindow gc False (round chx) (round chy)
        (if chw > 0 then round chw else 8) (round chh)

    return True

doLayout :: UI -> Editor -> IO Editor
doLayout ui e = do
    updateCache ui e
    tabs <- readRef $ tabCache ui
    f <- readRef (uiFont ui)
    heights <- fold <$> mapM (getHeightsInTab ui f e) tabs
    let e' = (tabsA %~ fmap (mapWindows updateWin)) e
        updateWin w = case M.lookup (wkey w) heights of
                          Nothing -> w
                          Just (h,rgn) -> w { height = h, winRegion = rgn }

    -- Don't leak references to old Windows
    let forceWin x w = height w `seq` winRegion w `seq` x
    return $ (foldl . tabFoldl) forceWin e' (e' ^. tabsA)

getHeightsInTab :: UI -> FontDescription -> Editor
                -> TabInfo -> IO (M.Map WindowRef (Int,Region))
getHeightsInTab ui f e tab = do
  wCache <- readIORef (windowCache tab)
  forM wCache $ \wi -> do
    (_, h) <- widgetGetSize $ textview wi
    win <- readIORef (coreWin wi)
    let metrics = winMetrics wi
        lineHeight = ascent metrics + descent metrics
    let b0 = findBufferWith (bufkey win) e
    rgn <- shownRegion ui f wi b0
    let ret= (round $ fromIntegral h / lineHeight, rgn)
    return ret

shownRegion :: UI -> FontDescription -> WinInfo -> FBuffer -> IO Region
shownRegion ui f w b = modifyMVar (winLayoutInfo w) $ \wli -> do
   (tos, cur, bos, bufEnd) <- updatePango ui f w b (winLayout wli)
   return (wli{tos,cur=clampTo tos bos cur,bos,bufEnd}, mkRegion tos bos)
 where clampTo lo hi x = max lo (min hi x)
-- during scrolling, cur might not lie between tos and bos,
-- so we clamp it to avoid Pango errors

{-
Note [PangoLayout width]
~~~~~~~~~~~~~~~~~~~~~~~~

We start rendering the PangoLayout one pixel from the left of the
rendering area, which means a few +/-1 offsets in Pango rendering and
point lookup code. The reason for this is to support the "wide
cursor", which is 2 pixels wide. If we started rendering the
PangoLayout directly from the left of the rendering area instead of at
a 1-pixel offset, then the "wide cursor" would only be half-displayed
when the cursor is at the beginning of the line, and would then be a
"thin cursor".

An alternative would be to special-case the wide cursor rendering at
the beginning of the line, and draw it one pixel to the right of where
it "should" be. I haven't tried this out to see how it looks.

Reiner
-}

-- we update the regex and the buffer to avoid holding on to potential garbage.
-- These will be overwritten with correct values soon, in
-- updateWinInfoForRendering.
updatePango :: UI -> FontDescription -> WinInfo -> FBuffer
            -> PangoLayout -> IO (Point, Point, Point, Point)
updatePango ui font w b layout = do
  (width_', height') <- widgetGetSize $ textview w
  let width' = max 0 (width_' - 1) -- see Note [PangoLayout width]

  oldFont <- layoutGetFontDescription layout
  oldFontStr <- maybe (return Nothing)
                (fmap Just . fontDescriptionToString) oldFont
  newFontStr <- Just <$> fontDescriptionToString font
  when (oldFontStr /= newFontStr) (layoutSetFontDescription layout (Just font))

  win <- readIORef (coreWin w)
  let [width'', height''] = fmap fromIntegral [width', height']
      metrics             = winMetrics w
      lineHeight          = ascent metrics + descent metrics
      winh                = max 1 $ floor (height'' / lineHeight)

      (tos, size, point, text) = askBuffer win b $ do
        from     <- getMarkPointB =<< fromMark <$> askMarks
        rope     <- streamB Forward from
        p        <- pointB
        bufEnd     <- sizeB
        let content = fst $ Rope.splitAtLine winh rope
        -- allow BOS offset to be just after the last line
        let addNL = if Rope.countNewLines content == winh
                        then id
                        else (++"\n")
        return (from, bufEnd, p, addNL $ Rope.toString content)

  if configLineWrap $ uiConfig ui
    then do oldWidth <- layoutGetWidth layout
            when (oldWidth /= Just width'')
              (layoutSetWidth layout $ Just width'')
    else do
    (Rectangle px _py pwidth _pheight, _) <- layoutGetPixelExtents layout
    widgetSetSizeRequest (textview w) (px+pwidth) (-1)

  -- optimize for cursor movement
  oldText <- layoutGetText layout
  when (oldText /= text) (layoutSetText layout text)

  (_, bosOffset, _) <- layoutXYToIndex layout width''
                       (fromIntegral winh * lineHeight - 1)
  return (tos, point, tos + fromIntegral bosOffset + 1, size)

reloadProject :: IO ()
reloadProject = return ()

mkCol :: Bool -- ^ is foreground?
      -> Yi.Style.Color -> Gtk.Color
mkCol True  Default = Color 0 0 0
mkCol False Default = Color maxBound maxBound maxBound
mkCol _ (RGB x y z) = Color (fromIntegral x * 256)
                            (fromIntegral y * 256)
                            (fromIntegral z * 256)

-- * GTK Event handlers

-- | Process GTK keypress if IM fails
handleKeypress :: (Event -> IO ()) -- ^ Event dispatcher (Yi.Core.dispatch)
                  -> IMContext
                  -> EventM EKey Bool
handleKeypress ch im = do
  gtkMods <- eventModifier
  gtkKey  <- eventKeyVal
  ifIM    <- imContextFilterKeypress im
  let char = keyToChar gtkKey
      modsWithShift = M.keys $ M.filter (`elem` gtkMods) modTable
      mods | isJust char = filter (/= MShift) modsWithShift
           | otherwise   = modsWithShift
      key  = case char of
        Just c  -> Just $ KASCII c
        Nothing -> M.lookup (keyName gtkKey) keyTable

  case (ifIM, key) of
    (True, _   ) -> return ()
    (_, Nothing) -> logPutStrLn $ "Event not translatable: " ++ show key
    (_, Just k ) -> io $ ch $ Event k mods
  return True

-- | Map Yi modifiers to GTK
modTable :: M.Map Modifier EventM.Modifier
modTable = M.fromList
    [ (MShift, EventM.Shift  )
    , (MCtrl,  EventM.Control)
    , (MMeta,  EventM.Alt    )
    , (MSuper, EventM.Super  )
    , (MHyper, EventM.Hyper  )
    ]

-- | Same as Gtk.on, but discards the ConnectId
on :: object -> Signal object callback -> callback -> IO ()
on widget signal handler = void $ Gtk.on widget signal handler

handleButtonClick :: UI -> WindowRef -> EventM EButton Bool
handleButtonClick ui ref = do
  (x, y) <- eventCoordinates
  click  <- eventClick
  button <- eventButton
  io $ do
    w <- getWinInfo ui ref
    point <- pointToOffset (x, y) w

    let focusWindow = focusWindowE ref
        runAction = uiActionCh ui . makeAction

    runAction focusWindow
    case (click, button) of
      (SingleClick, LeftButton) ->  do
        io $ writeIORef (lButtonPressed w) True
        win <- io $ readIORef (coreWin w)
        runAction $ do
          b <- gets $ bkey . findBufferWith (bufkey win)
          withGivenBufferAndWindow0 win b $ do
            m <- selMark <$> askMarks
            setMarkPointB m point
            moveTo point
            setVisibleSelection False
      _ -> return ()

    return True

handleButtonRelease :: UI -> WinInfo -> EventM EButton Bool
handleButtonRelease ui w = do
  (x, y)   <- eventCoordinates
  button   <- eventButton
  io $ do
    point <- pointToOffset (x, y) w
    disp  <- widgetGetDisplay $ textview w
    cb    <- clipboardGetForDisplay disp selectionPrimary
    case button of
         MiddleButton -> pasteSelectionClipboard ui w point cb
         LeftButton   -> setSelectionClipboard   ui w cb >>
                         writeIORef (lButtonPressed w) False
         _            -> return ()
  return True

handleScroll :: UI -> WinInfo -> EventM EScroll Bool
handleScroll ui w = do
  scrollDirection <- eventScrollDirection
  xy <- eventCoordinates
  io $ do
    ifPressed <- readIORef $ lButtonPressed w
    -- query new coordinates
    let editorAction =
          withBuffer0 $ scrollB $ case scrollDirection of
            ScrollUp   -> negate configAmount
            ScrollDown -> configAmount
            _          -> 0 -- Left/right scrolling not supported
        configAmount = configScrollWheelAmount $ uiConfig ui
    uiActionCh ui (makeAction editorAction)
    when ifPressed $ selectArea ui w xy
  return True

handleConfigure :: UI -> EventM EConfigure Bool
handleConfigure ui = do
  -- trigger a layout
  -- why does this cause a hang without postGUIAsync?
  io $ postGUIAsync $ uiActionCh ui (makeAction (return () :: EditorM()))
  return False -- allow event to be propagated

handleMove :: UI -> WinInfo -> EventM EMotion Bool
handleMove ui w = eventCoordinates >>= (io . selectArea ui w) >>
                  return True

handleDividerMove :: (Action -> IO ()) -> DividerRef -> DividerPosition -> IO ()
handleDividerMove actionCh ref pos =
  actionCh (makeAction (setDividerPosE ref pos))

-- | Convert point coordinates to offset in Yi window
pointToOffset :: (Double, Double) -> WinInfo -> IO Point
pointToOffset (x,y) w =
  withMVar (winLayoutInfo w) $ \WinLayoutInfo{winLayout,tos,bufEnd} -> do
    im <- readIORef (insertingMode w)

    -- see Note [PangoLayout width]
    (_, charOffsetX, extra) <- layoutXYToIndex winLayout (max 0 (x-1)) y
    return $ min bufEnd (tos + fromIntegral
                         (charOffsetX + if im then extra else 0))

selectArea :: UI -> WinInfo -> (Double, Double) -> IO ()
selectArea ui w (x,y) = do
  p <- pointToOffset (x,y) w
  let editorAction = do
        txt <- withBuffer0 $ do
          moveTo p
          setVisibleSelection True
          readRegionB =<< getSelectRegionB
        setRegE txt

  uiActionCh ui (makeAction editorAction)
  -- drawWindowGetPointer (textview w) -- be ready for next message.

pasteSelectionClipboard :: UI -> WinInfo -> Point -> Clipboard -> IO ()
pasteSelectionClipboard ui w p cb = do
  win <- io $ readIORef (coreWin w)
  let cbHandler Nothing    = return ()
      cbHandler (Just txt) = uiActionCh ui $ makeAction $ do
        b <- gets $ bkey . findBufferWith (bufkey win)
        withGivenBufferAndWindow0 win b $ do
          pointB >>= setSelectionMarkPointB
          moveTo p
          insertN txt
  clipboardRequestText cb cbHandler

-- | Set selection clipboard contents to current selection
setSelectionClipboard :: UI -> WinInfo -> Clipboard -> IO ()
setSelectionClipboard ui _w cb = do
  -- Why uiActionCh doesn't allow returning values?
  selection <- newIORef ""
  let yiAction = do
        txt <- withEditor $ withBuffer0 $
               readRegionB =<< getSelectRegionB :: YiM String
        io $ writeIORef selection txt
  uiActionCh ui $ makeAction yiAction
  txt <- readIORef selection

  unless (null txt) $ clipboardSetText cb txt



-- Some useful stuff from `startNoMsg`
--
-- Disable the left pane (file/module browser) until Shim/Scion discussion has
-- concluded. Shim causes crashes, but it's not worth fixing if we'll soon
-- replace it.

{-
tabs' <- notebookNew
widgetSetSizeRequest tabs' 200 (-1)
notebookSetTabPos tabs' PosBottom
panedAdd1 paned tabs'

-- Create the tree views for files and modules
(filesProject, modulesProject) <- loadProject =<< getCurrentDirectory

filesStore   <- treeStoreNew [filesProject]
modulesStore <- treeStoreNew [modulesProject]

filesTree   <- projectTreeNew (outCh . singleton) filesStore
modulesTree <- projectTreeNew (outCh . singleton) modulesStore

scrlProject <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrlProject filesTree
scrolledWindowSetPolicy scrlProject PolicyAutomatic PolicyAutomatic
notebookAppendPage tabs scrlProject "Project"

scrlModules <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrlModules modulesTree
scrolledWindowSetPolicy scrlModules PolicyAutomatic PolicyAutomatic
notebookAppendPage tabs scrlModules "Modules"
-}