{-# LANGUAGE RecordWildCards, ScopedTypeVariables, MultiParamTypeClasses
           , DeriveDataTypeable, OverloadedStrings
           , GeneralizedNewtypeDeriving, FlexibleContexts #-}

-- this module isn't finished, and there's heaps of warnings.
{-# OPTIONS_GHC -w #-}

-- |
-- Module      :  Yi.Frontend.Pango.Control
-- License     :  GPL

module Yi.Frontend.Pango.Control (
    Control(..)
  , ControlM(..)
  , Buffer(..)
  , View(..)
  , Iter(..)
  , startControl
  , runControl
  , controlIO
  , liftYi
  , getControl
  , newBuffer
  , newView
  , getBuffer
  , setBufferMode
  , withCurrentBuffer
  , setText
  , getText
  , keyTable
  ) where

import Data.Text (unpack, pack, Text)
import qualified Data.Text as T
import Prelude hiding (concatMap, concat, foldl, elem, mapM_)
import Control.Exception (catch)
import Control.Monad        hiding (mapM_, forM_)
import Control.Monad.Reader hiding (mapM_, forM_)
import Control.Applicative
import Lens.Micro.Platform hiding (views, Action)
import Data.Foldable
import Data.Maybe (maybe, fromJust, fromMaybe)
import Data.Monoid
import Data.IORef
import Data.List (nub, filter, drop, zip, take, length)
import Data.Prototype
import Yi.Rope (toText, splitAtLine, YiString)
import qualified Yi.Rope as R
import qualified Data.Map as Map
import Yi.Core (startEditor, focusAllSyntax)
import Yi.Buffer
import Yi.Config
import Yi.Tab
import Yi.Window as Yi
import Yi.Editor
import Yi.Event
import Yi.Keymap
import Yi.Monad
import Yi.Style
import Yi.UI.Utils
import Yi.Utils
import Yi.Debug
import Graphics.UI.Gtk as Gtk
       (Color(..), PangoRectangle(..), Rectangle(..), selectionDataSetText,
        targetString, clipboardSetWithData, clipboardRequestText,
        selectionPrimary, clipboardGetForDisplay, widgetGetDisplay,
        onMotionNotify, drawRectangle, drawLine,
        layoutIndexToPos, layoutGetCursorPos, drawLayout,
        widgetGetDrawWindow, layoutSetAttributes, widgetGrabFocus,
        scrolledWindowSetPolicy, scrolledWindowAddWithViewport,
        scrolledWindowNew, contextGetMetrics, contextGetLanguage,
        layoutSetFontDescription, layoutEmpty, widgetCreatePangoContext,
        widgetModifyBg, drawingAreaNew, FontDescription, ScrolledWindow,
        FontMetrics, Language, DrawingArea, layoutXYToIndex, layoutSetText,
        layoutGetText, widgetSetSizeRequest, layoutGetPixelExtents,
        layoutSetWidth, layoutGetWidth, layoutGetFontDescription,
        PangoLayout, descent, ascent, widgetGetSize, widgetQueueDraw,
        mainQuit, signalDisconnect, ConnectId(..), PolicyType(..),
        StateType(..), EventMask(..), AttrOp(..), Weight(..),
        PangoAttribute(..), Underline(..), FontStyle(..))
import Graphics.UI.Gtk.Gdk.GC as Gtk
  (newGCValues, gcSetValues, gcNew, foreground)
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.Gdk.Events as Gdk.Events
import System.Glib.GError
import Control.Monad.Reader (ask, asks, MonadReader(..))
import Control.Monad.State (ap, get, put, modify)
import Control.Monad.Base
import Control.Concurrent (newMVar, modifyMVar, MVar, newEmptyMVar, putMVar,
                           readMVar, isEmptyMVar)
import Data.Typeable
import qualified Data.List.PointedList as PL (insertRight, withFocus,
                                              PointedList(..), singleton)
import Yi.Regex ((=~), AllTextSubmatches(..))
import Yi.String (showT)
import System.FilePath
import qualified Yi.UI.Common as Common

data Control = Control
    { controlYi :: Yi
    , tabCache  :: IORef [TabInfo]
    , views     :: IORef (Map.Map WindowRef View)
    }
--    { config  :: Config
--    , editor  :: Editor
--    , input   :: Event -> IO ()
--    , output  :: Action -> IO ()
--    }

data TabInfo = TabInfo
    { coreTab     :: Tab
--    , page        :: VBox
    }

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

--type ControlM = YiM
newtype ControlM a = ControlM { runControl'' :: ReaderT Control IO a }
    deriving (Monad, MonadBase IO, MonadReader Control, Typeable,
              Functor, Applicative)

-- Helper functions to avoid issues with mismatching monad libraries
controlIO :: IO a -> ControlM a
controlIO = liftBase

getControl :: ControlM Control
getControl = ask

liftYi :: YiM a -> ControlM a
liftYi m = do
    yi <- asks controlYi
    liftBase $ runReaderT (runYiM m) yi

--instance MonadState Editor ControlM where
--    get = readRef =<< editor <$> ask
--    put v = flip modifyRef (const v) =<< editor <$> ask

--instance MonadEditor ControlM where
--    askCfg = config <$> ask
--    withEditor f = do
--      r <- asks editor
--      cfg <- asks config
--      liftBase $ controlUnsafeWithEditor cfg r f

startControl :: Config -> ControlM () -> IO ()
startControl config main = startEditor (config { startFrontEnd = start main } ) Nothing

runControl' :: ControlM a -> MVar Control -> IO (Maybe a)
runControl' m yiMVar = do
    empty <- isEmptyMVar yiMVar
    if empty
        then return Nothing
        else do
            yi <- readMVar yiMVar
            result <- runControl m yi
            return $ Just result

-- runControl :: ControlM a -> Yi -> IO a
-- runControl m yi = runReaderT (runYiM m) yi

runControl :: ControlM a -> Control -> IO a
runControl f = runReaderT (runControl'' f)

-- runControlEditor f yiMVar = yiMVar

runAction :: Action -> ControlM ()
runAction action = do
    out <- liftYi $ asks yiOutput
    liftBase $ out MustRefresh [action]

-- | Test 2
mkUI :: IO () -> MVar Control -> Common.UI Editor
mkUI main yiMVar = Common.dummyUI
    { Common.main          = main
    , Common.end           = \_ -> void $ runControl' end yiMVar
    , Common.suspend       = void $ runControl' suspend yiMVar
    , Common.refresh       = \e -> void $ runControl' (refresh e) yiMVar
    , Common.layout        = \e -> fmap (fromMaybe e) $
                                   runControl' (doLayout e) yiMVar
    , Common.reloadProject = \f -> void $ runControl' (reloadProject f) yiMVar
    }

start :: ControlM () -> UIBoot
start main cfg ch outCh ed =
  catch (startNoMsg main cfg ch outCh ed) (\(GError _dom _code msg) ->
                                            fail $ unpack msg)

makeControl :: MVar Control -> YiM ()
makeControl controlMVar = do
    controlYi <- ask
    tabCache  <- liftBase $ newIORef []
    views  <- liftBase $ newIORef Map.empty
    liftBase $ putMVar controlMVar Control{..}

startNoMsg :: ControlM () -> UIBoot
startNoMsg main config input output ed = do
    control <- newEmptyMVar
    let wrappedMain = do
          output [makeAction $ makeControl control]
          void (runControl' main control)
    return (mkUI wrappedMain control)

end :: ControlM ()
end = do
    liftBase $ putStrLn "Yi Control End"
    liftBase mainQuit

suspend :: ControlM ()
suspend = do
    liftBase $ putStrLn "Yi Control Suspend"
    return ()

{-# ANN refresh ("HLint: ignore Redundant do" :: String) #-}
refresh :: Editor -> ControlM ()
refresh e = do
    --contextId <- statusbarGetContextId (uiStatusbar ui) "global"
    --statusbarPop  (uiStatusbar ui) contextId
    --statusbarPush (uiStatusbar ui) contextId $ intercalate "  " $ statusLine e

    updateCache e -- The cursor may have changed since doLayout
    viewsRef <- asks views
    vs <- liftBase $ readIORef viewsRef
    forM_ (Map.elems vs) $ \v -> do
        let b = findBufferWith (viewFBufRef v) e
        -- when (not $ null $ b ^. pendingUpdatesA) $
        do
            -- sig <- readIORef (renderer w)
            -- signalDisconnect sig
            -- writeRef (renderer w)
            -- =<< (textview w `onExpose` render e ui b (wkey (coreWin w)))
            liftBase $ widgetQueueDraw (drawArea v)

doLayout :: Editor -> ControlM Editor
doLayout e = do
    liftBase $ putStrLn "Yi Control Do Layout"
    updateCache e
    cacheRef <- asks tabCache
    tabs <- liftBase $ readIORef cacheRef
    dims <- concat <$> mapM (getDimensionsInTab e) tabs
    let e' = (tabsA %~ fmap (mapWindows updateWin)) e
        updateWin w = case find (\(ref,_,_,_) -> (wkey w == ref)) dims of
                          Nothing -> w
                          Just (_, wi, h,rgn) -> w { width = wi
                                                   , 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)

-- | Width, Height
getDimensionsInTab :: Editor -> TabInfo -> ControlM [(WindowRef,Int,Int,Region)]
getDimensionsInTab e tab = do
  viewsRef <- asks views
  vs <- liftBase $ readIORef viewsRef
  foldlM (\a w ->
        case Map.lookup (wkey w) vs of
            Just v -> do
                (wi, h) <- liftBase $ widgetGetSize $ drawArea v
                let lineHeight = ascent (metrics v) + descent (metrics v)
                    charWidth = Gtk.approximateCharWidth $ metrics v
                    b0 = findBufferWith (viewFBufRef v) e
                rgn <- shownRegion e v b0
                let ret= (windowRef v, round $ fromIntegral wi / charWidth, 
                          round $ fromIntegral h / lineHeight, rgn)
                return $ a <> [ret]
            Nothing -> return a)
      [] (coreTab tab ^. tabWindowsA)

shownRegion :: Editor -> View -> FBuffer -> ControlM Region
shownRegion e v b = do
   (tos, _, bos) <- updatePango e v b (layout v)
   return $ mkRegion tos bos

updatePango :: Editor -> View -> FBuffer -> PangoLayout
            -> ControlM (Point, Point, Point)
updatePango e v b layout = do
  (width', height') <- liftBase $ widgetGetSize $ drawArea v

  font <- liftBase $ layoutGetFontDescription layout

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

  let win                 = findWindowWith (windowRef v) e
      [width'', height''] = map fromIntegral [width', height']
      lineHeight          = ascent (metrics v) + descent (metrics v)
      winh                = max 1 $ floor (height'' / lineHeight)

      (tos, point, text)  = askBuffer win b $ do
                              from <- (use . markPointA) =<< fromMark <$> askMarks
                              rope <- streamB Forward from
                              p    <- pointB
                              let content = fst $ splitAtLine winh rope
                              -- allow BOS offset to be just after the last line
                              let addNL = if R.countNewLines content == winh
                                          then id
                                          else (`R.snoc` '\n')
                              return (from, p, R.toText $ addNL content)

  config   <- liftYi askCfg
  if configLineWrap $ configUI config
    then do oldWidth <- liftBase $ layoutGetWidth layout
            when (oldWidth /= Just width'') $
              liftBase $ layoutSetWidth layout $ Just width''
    else do
    (Rectangle px _py pwidth _pheight, _) <- liftBase $
                                             layoutGetPixelExtents layout
    liftBase $ widgetSetSizeRequest (drawArea v) (px+pwidth) (-1)

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

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

updateCache :: Editor -> ControlM ()
updateCache e = do
    let tabs = e ^. tabsA
    cacheRef <- asks tabCache
    cache <- liftBase $ readIORef cacheRef
    cache' <- syncTabs e (toList $ PL.withFocus tabs) cache
    liftBase $ writeIORef cacheRef cache'

syncTabs :: Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs e (tfocused@(t,focused):ts) (c:cs)
    | t == coreTab c =
        do when focused $ setTabFocus c
--           let vCache = views c
           (:) <$> syncTab e c t <*> syncTabs e ts cs
    | t `elem` map coreTab cs =
        do removeTab c
           syncTabs e (tfocused:ts) cs
    | otherwise =
        do c' <- insertTabBefore e t c
           when focused $ setTabFocus c'
           return (c':) `ap` syncTabs e ts (c:cs)
syncTabs e ts [] = mapM (\(t,focused) -> do
        c' <- insertTab e t
        when focused $ setTabFocus c'
        return c') ts
syncTabs _ [] cs = mapM_ removeTab cs >> return []

syncTab :: Editor -> TabInfo -> Tab -> ControlM TabInfo
syncTab e tab ws =
  -- TODO Maybe do something here
  return tab

setTabFocus :: TabInfo -> ControlM ()
setTabFocus t =
  -- TODO this needs to set the tab focus with callback
  -- but only if the tab focus has changed
  return ()

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

setWindowFocus :: Editor -> TabInfo -> View -> ControlM ()
setWindowFocus e t v = do
  let bufferName = shortIdentString (length $ commonNamePrefix e) $
                   findBufferWith (viewFBufRef v) e
      window = findWindowWith (windowRef v) e
      ml = askBuffer window (findBufferWith (viewFBufRef v) e) $
           getModeLine (T.pack <$> commonNamePrefix e)

-- TODO
--  update (textview w) widgetIsFocus True
--  update (modeline w) labelText ml
--  update (uiWindow ui) windowTitle $ bufferName <> " - Yi"
--  update (uiNotebook ui) (notebookChildTabLabel (page t))
--    (tabAbbrevTitle bufferName)
  return ()

removeTab :: TabInfo -> ControlM ()
removeTab t =
  -- TODO this needs to close the views in the tab with callback
  return ()

removeView :: TabInfo -> View -> ControlM ()
removeView tab view =
  -- TODO this needs to close the view with callback
  return ()

-- | Make a new tab.
newTab :: Editor -> Tab -> ControlM TabInfo
newTab e ws = do
    let t' = TabInfo { coreTab = ws }
--    cache <- syncWindows e t' (toList $ PL.withFocus ws) []
    return t' -- { views = cache }

{-# ANN insertTabBefore ("HLint: ignore Redundant do" :: String) #-}
insertTabBefore :: Editor -> Tab -> TabInfo -> ControlM TabInfo
insertTabBefore e ws c = do
    -- Just p <- notebookPageNum (uiNotebook ui) (page c)
    -- vb <- vBoxNew False 1
    -- notebookInsertPage (uiNotebook ui) vb "" p
    -- widgetShowAll $ vb
    newTab e ws

{-# ANN insertTab ("HLint: ignore Redundant do" :: String) #-}
insertTab :: Editor -> Tab -> ControlM TabInfo
insertTab e ws = do
    -- vb <- vBoxNew False 1
    -- notebookAppendPage (uiNotebook ui) vb ""
    -- widgetShowAll $ vb
    newTab e ws

{-
insertWindowBefore :: Editor -> TabInfo -> Yi.Window -> WinInfo -> IO WinInfo
insertWindowBefore e ui tab w _c = insertWindow e ui tab w

insertWindowAtEnd :: Editor -> UI -> TabInfo -> Window -> IO WinInfo
insertWindowAtEnd e ui tab w = insertWindow e ui tab w

insertWindow :: Editor -> UI -> TabInfo -> Window -> IO WinInfo
insertWindow e ui tab win = do
  let buf = findBufferWith (bufkey win) e
  liftBase $ do w <- newWindow e ui win buf

              set (page tab) $
                [ containerChild := widget w
                , boxChildPacking (widget w) :=
                    if isMini (coreWin w)
                        then PackNatural
                        else PackGrow
                ]

              let ref = (wkey . coreWin) w
              textview w `onButtonRelease` handleClick ui ref
              textview w `onButtonPress` handleClick ui ref
              textview w `onScroll` handleScroll ui ref
              textview w `onConfigure` handleConfigure ui ref
              widgetShowAll (widget w)

              return w
-}

reloadProject :: FilePath -> ControlM ()
reloadProject _ = return ()

controlUnsafeWithEditor :: Config -> MVar Editor -> EditorM a -> IO a
controlUnsafeWithEditor cfg r f = modifyMVar r $ \e -> do
  let (e',a) = runEditor cfg f e
  -- Make sure that the result of runEditor is evaluated before
  -- replacing the editor state. Otherwise, we might replace e
  -- with an exception-producing thunk, which makes it impossible
  -- to look at or update the editor state.
  -- Maybe this could also be fixed by -fno-state-hack flag?
  -- TODO: can we simplify this?
  e' `seq` a `seq` return (e', a)

data Buffer = Buffer
    { fBufRef     :: BufferRef
    }

data View = View
    { viewFBufRef :: BufferRef
    , windowRef   :: WindowRef
    , drawArea    :: DrawingArea
    , layout      :: PangoLayout
    , language    :: Language
    , metrics     :: FontMetrics
    , scrollWin   :: ScrolledWindow
    , shownTos    :: IORef Point
    , winMotionSignal :: IORef (Maybe (ConnectId DrawingArea))
    }

data Iter = Iter
    { iterFBufRef :: BufferRef
    , point       :: Point
    }

newBuffer :: BufferId -> R.YiString -> ControlM Buffer
newBuffer id text = do
    fBufRef <- liftYi . withEditor . newBufferE id $ text
    return Buffer{..}

newView :: Buffer -> FontDescription -> ControlM View
newView buffer font = do
    control  <- ask
    config   <- liftYi askCfg
    let viewFBufRef = fBufRef buffer
    newWindow <-
      fmap (\w -> w { height=50
                    , winRegion = mkRegion (Point 0) (Point 2000)
                    }) $ liftYi $ withEditor $ newWindowE False viewFBufRef
    let windowRef = wkey newWindow
    liftYi $ withEditor $ do
        windowsA %= PL.insertRight newWindow
        e <- get
        put $ focusAllSyntax e
    drawArea <- liftBase drawingAreaNew
    liftBase . widgetModifyBg drawArea StateNormal . mkCol False
      . Yi.Style.background . baseAttributes . configStyle $ configUI config
    context  <- liftBase $ widgetCreatePangoContext drawArea
    layout   <- liftBase $ layoutEmpty context
    liftBase $ layoutSetFontDescription layout (Just font)
    language <- liftBase $ contextGetLanguage context
    metrics  <- liftBase $ contextGetMetrics context font language
    liftBase $ layoutSetText layout ("" :: Text)

    scrollWin <- liftBase $ scrolledWindowNew Nothing Nothing
    liftBase $ do
        scrolledWindowAddWithViewport scrollWin drawArea
        scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyNever

    initialTos <-
      liftYi . withEditor . withGivenBufferAndWindow newWindow viewFBufRef $
        (use . markPointA) =<< fromMark <$> askMarks
    shownTos <- liftBase $ newIORef initialTos
    winMotionSignal <- liftBase $ newIORef Nothing

    let view = View {..}

    liftBase $ Gtk.widgetAddEvents drawArea [KeyPressMask]
    liftBase $ Gtk.set drawArea [Gtk.widgetCanFocus := True]

    liftBase $ drawArea `Gtk.onKeyPress` \event -> do
        putStrLn $ "Yi Control Key Press = " <> show event
        runControl (runAction $ makeAction $ do
            focusWindowE windowRef
            switchToBufferE viewFBufRef) control
        result <- processEvent (yiInput $ controlYi control) event
        widgetQueueDraw drawArea
        return result

    liftBase $ drawArea `Gtk.onButtonPress` \event -> do
        widgetGrabFocus drawArea
        runControl (handleClick view event) control

    liftBase $ drawArea `Gtk.onButtonRelease` \event ->
        runControl (handleClick view event) control

    liftBase $ drawArea `Gtk.onScroll` \event ->
        runControl (handleScroll view event) control

    liftBase $ drawArea `Gtk.onExpose` \event -> do
        (text, allAttrs, debug, tos, rel, point, inserting) <-
          runControl (liftYi $ withEditor $ do
            window <- findWindowWith windowRef <$> get
            (%=) buffersA (fmap (clearSyntax . clearHighlight))
            let winh = height window
            let tos = max 0 (regionStart (winRegion window))
            let bos = regionEnd (winRegion window)
            let rel p = fromIntegral (p - tos)

            withGivenBufferAndWindow window viewFBufRef $ do
                -- tos       <- getMarkPointB =<< fromMark <$> askMarks
                rope      <- streamB Forward tos
                point     <- pointB
                inserting <- use insertingA

                modeNm <- gets (withMode0 modeName)

    --            let (tos, point, text, picture) = do runBu
    --                        from     <- getMarkPointB =<< fromMark <$> askMarks
    --                        rope     <- streamB Forward from
    --                        p        <- pointB
                let content = fst $ splitAtLine winh rope
                -- allow BOS offset to be just after the last line
                let addNL = if R.countNewLines content == winh
                              then id
                              else (`R.snoc` '\n')
                    sty = configStyle $ configUI config
                          -- attributesPictureAndSelB sty (currentRegex e)
                          --   (mkRegion tos bos)
                          -- return (from, p, addNL $ Rope.toString content,
                          --         picture)
                let text = R.toText $ addNL content

                picture <- attributesPictureAndSelB sty Nothing
                           (mkRegion tos bos)

                -- add color attributes.
                let 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
                             ]


                return (text, allAttrs, (picture, strokes, modeNm,
                                         window, tos, bos, winh),
                        tos, rel, point, inserting)) control

        -- putStrLn $ "Setting Layout Attributes " <> show debug
        layoutSetAttributes layout allAttrs
        -- putStrLn "Done Stting Layout Attributes"
        dw      <- widgetGetDrawWindow drawArea
        gc      <- gcNew dw
        oldText <- layoutGetText layout
        when (text /= oldText) $ layoutSetText layout text
        drawLayout dw gc 0 0 layout
        liftBase $ writeIORef shownTos tos

        -- paint the cursor
        (PangoRectangle curx cury curw curh, _) <-
          layoutGetCursorPos layout (rel point)
        PangoRectangle chx chy chw chh          <-
          layoutIndexToPos layout (rel point)

        gcSetValues gc
          (newGCValues { Gtk.foreground = mkCol True . Yi.Style.foreground
                                          . baseAttributes . configStyle $
                                          configUI config })
        if inserting
          then drawLine dw gc (round curx, round cury) (round $ curx + curw, round $ cury + curh)
          else drawRectangle dw gc False (round chx) (round chy) (if chw > 0 then round chw else 8) (round chh)

        return True

    liftBase $ widgetGrabFocus drawArea

    tabsRef <- asks tabCache
    ts <- liftBase $ readIORef tabsRef
    -- TODO: the Tab idkey should be assigned using
    -- Yi.Editor.newRef. But we can't modify that here, since our
    -- access to 'Yi' is readonly.
    liftBase $ writeIORef tabsRef (TabInfo (makeTab1 0 newWindow):ts)

    viewsRef <- asks views
    vs <- liftBase $ readIORef viewsRef
    liftBase $ writeIORef viewsRef $ Map.insert windowRef view vs

    return view
  where
    clearHighlight fb =
      -- if there were updates, then hide the selection.
      let h = view highlightSelectionA fb
          us = view pendingUpdatesA fb
      in highlightSelectionA .~ (h && null us) $ fb

{-# ANN setBufferMode ("HLint: ignore Redundant do" :: String) #-}
setBufferMode :: FilePath -> Buffer -> ControlM ()
setBufferMode f buffer = do
    let bufRef = fBufRef buffer
    -- adjust the mode
    tbl <- liftYi $ asks (modeTable . yiConfig)
    contents <- liftYi $ withGivenBuffer bufRef elemsB
    let header = R.toString $ R.take 1024 contents
        hmode = case header =~ ("\\-\\*\\- *([^ ]*) *\\-\\*\\-" :: String) of
            AllTextSubmatches [_,m] -> T.pack m
            _ -> ""
        Just mode = find (\(AnyMode m)-> modeName m == hmode) tbl <|>
                    find (\(AnyMode m)-> modeApplies m f contents) tbl <|>
                    Just (AnyMode emptyMode)
    case mode of
        AnyMode newMode -> do
            -- liftBase $ putStrLn $ show (f, modeName newMode)
            liftYi $ withEditor $ do
                withGivenBuffer bufRef $ do
                    setMode newMode
                    modify clearSyntax
                switchToBufferE bufRef
            -- withEditor focusAllSyntax

withBuffer :: Buffer -> BufferM a -> ControlM a
withBuffer Buffer{fBufRef = b} f = liftYi $ withGivenBuffer b f

getBuffer :: View -> Buffer
getBuffer view = Buffer {fBufRef = viewFBufRef view}

setText :: Buffer -> YiString -> ControlM ()
setText b text = withBuffer b $ do
    r <- regionOfB Document
    replaceRegionB r text

getText :: Buffer -> Iter -> Iter -> ControlM Text
getText b Iter{point = p1} Iter{point = p2} =
  fmap toText . withBuffer b . readRegionB $ mkRegion p1 p2

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)

handleClick :: View -> Gdk.Events.Event -> ControlM Bool
handleClick view event = do
  control  <- ask
  -- (_tabIdx,winIdx,w) <- getWinInfo ref <$> readIORef (tabCache ui)

  logPutStrLn $ "Click: " <> showT (Gdk.Events.eventX event,
                                    Gdk.Events.eventY event,
                                    Gdk.Events.eventClick event)

  -- retrieve the clicked offset.
  (_,layoutIndex,_) <- io $ layoutXYToIndex (layout view)
                       (Gdk.Events.eventX event) (Gdk.Events.eventY event)
  tos <- liftBase $ readIORef (shownTos view)
  let p1 = tos + fromIntegral layoutIndex

  let winRef = windowRef view

  -- maybe focus the window
  -- logPutStrLn $ "Clicked inside window: " <> show view

--  let focusWindow = do
      -- TODO: check that tabIdx is the focus?
--      (%=) windowsA (fromJust . PL.move winIdx)

  liftBase $ case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
     (Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
        cid <- onMotionNotify (drawArea view) False $ \event ->
            runControl (handleMove view p1 event) control
        writeIORef (winMotionSignal view) $ Just cid

     _ -> do
       maybe (return ()) signalDisconnect =<< readIORef (winMotionSignal view)
       writeIORef (winMotionSignal view) Nothing

  case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
    (Gdk.Events.SingleClick, Gdk.Events.LeftButton) ->
      runAction . EditorA $ do
        -- b <- gets $ (bkey . findBufferWith (viewFBufRef view))
        -- focusWindow
        window <- findWindowWith winRef <$> get
        withGivenBufferAndWindow window (viewFBufRef view) $ do
            moveTo p1
            setVisibleSelection False
    -- (Gdk.Events.SingleClick, _) -> runAction focusWindow
    (Gdk.Events.ReleaseClick, Gdk.Events.MiddleButton) -> do
        disp <- liftBase $ widgetGetDisplay (drawArea view)
        cb <- liftBase $ clipboardGetForDisplay disp selectionPrimary
        let cbHandler :: Maybe R.YiString -> IO ()
            cbHandler Nothing = return ()
            cbHandler (Just txt) = runControl (runAction . EditorA $ do
                window <- findWindowWith winRef <$> get
                withGivenBufferAndWindow window (viewFBufRef view) $ do
                    pointB >>= setSelectionMarkPointB
                    moveTo p1
                    insertN txt) control
        liftBase $ clipboardRequestText cb (cbHandler . fmap R.fromText)
    _ -> return ()

  liftBase $ widgetQueueDraw (drawArea view)
  return True

handleScroll :: View -> Gdk.Events.Event -> ControlM Bool
handleScroll view event = do
  let editorAction =
        withCurrentBuffer $ vimScrollB $ case Gdk.Events.eventDirection event of
                        Gdk.Events.ScrollUp   -> -1
                        Gdk.Events.ScrollDown -> 1
                        _ -> 0 -- Left/right scrolling not supported

  runAction $ EditorA editorAction
  liftBase $ widgetQueueDraw (drawArea view)
  return True

handleMove :: View -> Point -> Gdk.Events.Event -> ControlM Bool
handleMove view p0 event = do
  logPutStrLn $ "Motion: " <> showT (Gdk.Events.eventX event,
                                     Gdk.Events.eventY event)

  -- retrieve the clicked offset.
  (_,layoutIndex,_) <-
    liftBase $ layoutXYToIndex (layout view)
    (Gdk.Events.eventX event) (Gdk.Events.eventY event)
  tos <- liftBase $ readIORef (shownTos view)
  let p1 = tos + fromIntegral layoutIndex


  let editorAction = do
        txt <- withCurrentBuffer $
           if p0 /= p1
            then Just <$> do
              m <- selMark <$> askMarks
              markPointA m .= p0
              moveTo p1
              setVisibleSelection True
              readRegionB =<< getSelectRegionB
            else return Nothing
        maybe (return ()) setRegE txt

  runAction $ makeAction editorAction
  -- drawWindowGetPointer (textview w) -- be ready for next message.

  -- Relies on uiActionCh being synchronous
  selection <- liftBase $ newIORef ""
  let yiAction = do
        txt <- withCurrentBuffer (readRegionB =<< getSelectRegionB)
             :: YiM R.YiString
        liftBase $ writeIORef selection txt
  runAction $ makeAction yiAction
  txt <- liftBase $ readIORef selection

  disp <- liftBase $ widgetGetDisplay (drawArea view)
  cb <- liftBase $ clipboardGetForDisplay disp selectionPrimary
  liftBase $ clipboardSetWithData cb [(targetString,0)]
      (\0 -> void (selectionDataSetText $ R.toText txt)) (return ())

  liftBase $ widgetQueueDraw (drawArea view)
  return True

processEvent :: ([Event] -> IO ()) -> Gdk.Events.Event -> IO Bool
processEvent ch ev = do
  -- logPutStrLn $ "Gtk.Event: " <> show ev
  -- logPutStrLn $ "Event: " <> show (gtkToYiEvent ev)
  case gtkToYiEvent ev of
    Nothing -> logPutStrLn $ "Event not translatable: " <> showT ev
    Just e -> ch [e]
  return True

gtkToYiEvent :: Gdk.Events.Event -> Maybe Event
gtkToYiEvent (Gdk.Events.Key {Gdk.Events.eventKeyName = key
                             , Gdk.Events.eventModifier = evModifier
                             , Gdk.Events.eventKeyChar = char})
    = (\k -> Event k $ nub $ notMShift $ concatMap modif evModifier) <$> key'
      where (key',isShift) =
                case char of
                  Just c  -> (Just $ KASCII c, True)
                  Nothing -> (Map.lookup key keyTable, False)
            modif Gdk.Events.Control = [MCtrl]
            modif Gdk.Events.Alt     = [MMeta]
            modif Gdk.Events.Shift   = [MShift]
            modif _ = []
            notMShift | isShift   = filter (/= MShift)
                      | otherwise = id
gtkToYiEvent _ = Nothing

-- | Map GTK long names to Keys
keyTable :: Map.Map Text Key
keyTable = Map.fromList
    [("Down",       KDown)
    ,("Up",         KUp)
    ,("Left",       KLeft)
    ,("Right",      KRight)
    ,("Home",       KHome)
    ,("End",        KEnd)
    ,("BackSpace",  KBS)
    ,("Delete",     KDel)
    ,("Page_Up",    KPageUp)
    ,("Page_Down",  KPageDown)
    ,("Insert",     KIns)
    ,("Escape",     KEsc)
    ,("Return",     KEnter)
    ,("Tab",        KTab)
    ,("ISO_Left_Tab", KTab)
    ]
