{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- this file adds missing instances for GTK stuff
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Frontend.Pango
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- This module defines a user interface implemented using gtk2hs and
-- pango for direct text rendering.

module Yi.Frontend.Pango (start, startGtkHook) where

import           Control.Applicative
import           Control.Concurrent
import           Control.Exception (catch, SomeException)
import           Lens.Micro.Platform hiding (set)
import           Control.Monad hiding (forM_, mapM_, forM, mapM)
import           Data.Foldable
import           Data.IORef
import qualified Data.List.PointedList as PL (moveTo)
import qualified Data.List.PointedList.Circular as PL
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid
import           Data.Text (unpack, Text)
import qualified Data.Text as T
import           Data.Traversable
import qualified Graphics.UI.Gtk as Gtk
import           Graphics.UI.Gtk hiding (Region, Window, Action , Point,
                                         Style, Modifier, on)
import qualified Graphics.UI.Gtk.Gdk.EventM as EventM
import qualified Graphics.UI.Gtk.Gdk.GC as Gtk
import           Graphics.UI.Gtk.Gdk.GC hiding (foreground)
import           Prelude hiding (error, elem, mapM_, foldl, concat, mapM)
import           System.Glib.GError
import           Yi.Buffer
import           Yi.Config
import           Yi.Debug
import           Yi.Editor
import           Yi.Event
import           Yi.Keymap
import           Yi.Layout(DividerPosition, DividerRef)
import           Yi.Monad
import qualified Yi.Rope as R
import           Yi.Style
import           Yi.Tab
import           Yi.Types (fontsizeVariation, attributes)
import qualified Yi.UI.Common as Common
import           Yi.Frontend.Pango.Control (keyTable)
import           Yi.Frontend.Pango.Layouts
import           Yi.Frontend.Pango.Utils
import           Yi.String (showT)
import           Yi.UI.TabBar
import           Yi.UI.Utils
import           Yi.Utils
import           Yi.Window

-- 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
    { UI -> Window
uiWindow    :: Gtk.Window
    , UI -> SimpleNotebook
uiNotebook  :: SimpleNotebook
    , UI -> Statusbar
uiStatusbar :: Statusbar
    , UI -> IORef TabCache
tabCache    :: IORef TabCache
    , UI -> Action -> IO ()
uiActionCh  :: Action -> IO ()
    , UI -> UIConfig
uiConfig    :: UIConfig
    , UI -> IORef FontDescription
uiFont      :: IORef FontDescription
    , UI -> IMContext
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
    { TabInfo -> Int
coreTabKey      :: TabRef
    , TabInfo -> LayoutDisplay
layoutDisplay   :: LayoutDisplay
    , TabInfo -> MiniwindowDisplay
miniwindowPage  :: MiniwindowDisplay
    , TabInfo -> Widget
tabWidget       :: Widget
    , TabInfo -> IORef WindowCache
windowCache     :: IORef WindowCache
    , TabInfo -> IORef Text
fullTitle       :: IORef Text
    , TabInfo -> IORef Text
abbrevTitle     :: IORef Text
    }

instance Show TabInfo where
    show :: TabInfo -> String
show TabInfo
t = Int -> String
forall a. Show a => a -> String
show (TabInfo -> Int
coreTabKey TabInfo
t)

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

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

instance Show WinInfo where
    show :: WinInfo -> String
show WinInfo
w = WindowRef -> String
forall a. Show a => a -> String
show (WinInfo -> WindowRef
coreWinKey WinInfo
w)

instance Ord EventM.Modifier where
  Modifier
x <= :: Modifier -> Modifier -> Bool
<= Modifier
y = Modifier -> Int
forall a. Enum a => a -> Int
fromEnum Modifier
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Modifier -> Int
forall a. Enum a => a -> Int
fromEnum Modifier
y

mkUI :: UI -> Common.UI Editor
mkUI :: UI -> UI Editor
mkUI UI
ui = UI Any
forall e. UI e
Common.dummyUI
    { main :: IO ()
Common.main          = IO ()
main
    , end :: Maybe ExitCode -> IO ()
Common.end           = IO () -> Maybe ExitCode -> IO ()
forall a b. a -> b -> a
const IO ()
end
    , suspend :: IO ()
Common.suspend       = Window -> IO ()
forall self. WindowClass self => self -> IO ()
windowIconify (UI -> Window
uiWindow UI
ui)
    , refresh :: Editor -> IO ()
Common.refresh       = UI -> Editor -> IO ()
refresh UI
ui
    , layout :: Editor -> IO Editor
Common.layout        = UI -> Editor -> IO Editor
doLayout UI
ui
    , reloadProject :: String -> IO ()
Common.reloadProject = IO () -> String -> IO ()
forall a b. a -> b -> a
const IO ()
reloadProject
    }

updateFont :: UIConfig -> IORef FontDescription -> IORef TabCache -> Statusbar
           -> FontDescription -> IO ()
updateFont :: UIConfig
-> IORef FontDescription
-> IORef TabCache
-> Statusbar
-> FontDescription
-> IO ()
updateFont UIConfig
cfg IORef FontDescription
fontRef IORef TabCache
tc Statusbar
status FontDescription
font = do
    IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (FontDescription -> String -> IO ()
forall string.
GlibString string =>
FontDescription -> string -> IO ()
fontDescriptionSetFamily FontDescription
font) (UIConfig -> Maybe String
configFontName UIConfig
cfg)

    IORef FontDescription -> FontDescription -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FontDescription
fontRef FontDescription
font
    Statusbar -> Maybe FontDescription -> IO ()
forall self.
WidgetClass self =>
self -> Maybe FontDescription -> IO ()
widgetModifyFont Statusbar
status (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
font)
    TabCache
tcs <- IORef TabCache -> IO TabCache
forall a. IORef a -> IO a
readIORef IORef TabCache
tc
    TabCache -> (TabInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ TabCache
tcs ((TabInfo -> IO ()) -> IO ()) -> (TabInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TabInfo
tabinfo -> do
      WindowCache
wcs <- IORef WindowCache -> IO WindowCache
forall a. IORef a -> IO a
readIORef (TabInfo -> IORef WindowCache
windowCache TabInfo
tabinfo)
      WindowCache -> (WinInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ WindowCache
wcs ((WinInfo -> IO ()) -> IO ()) -> (WinInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WinInfo
wininfo -> do
        MVar WinLayoutInfo -> (WinLayoutInfo -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (WinInfo -> MVar WinLayoutInfo
winLayoutInfo WinInfo
wininfo) ((WinLayoutInfo -> IO ()) -> IO ())
-> (WinLayoutInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WinLayoutInfo{PangoLayout
winLayout :: WinLayoutInfo -> PangoLayout
winLayout :: PangoLayout
winLayout} ->
          PangoLayout -> Maybe FontDescription -> IO ()
layoutSetFontDescription PangoLayout
winLayout (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
font)

        -- This will cause the textview to redraw
        DrawingArea -> Maybe FontDescription -> IO ()
forall self.
WidgetClass self =>
self -> Maybe FontDescription -> IO ()
widgetModifyFont (WinInfo -> DrawingArea
textview WinInfo
wininfo) (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
font)
        Label -> Maybe FontDescription -> IO ()
forall self.
WidgetClass self =>
self -> Maybe FontDescription -> IO ()
widgetModifyFont (WinInfo -> Label
modeline WinInfo
wininfo) (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
font)

askBuffer :: Window -> FBuffer -> BufferM a -> a
askBuffer :: forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
w FBuffer
b BufferM a
f = (a, FBuffer) -> a
forall a b. (a, b) -> a
fst ((a, FBuffer) -> a) -> (a, FBuffer) -> a
forall a b. (a -> b) -> a -> b
$ Window -> FBuffer -> BufferM a -> (a, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
w FBuffer
b BufferM a
f

-- | Initialise the ui
start :: UIBoot
start :: UIBoot
start = (Window -> IO ()) -> UIBoot
startGtkHook (IO () -> Window -> IO ()
forall a b. a -> b -> a
const (IO () -> Window -> IO ()) -> IO () -> Window -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Initialise the ui, calling a given function
--   on the Gtk window. This could be used to
--   set additional callbacks, adjusting the window
--   layout, etc.
startGtkHook :: (Gtk.Window -> IO ()) -> UIBoot
startGtkHook :: (Window -> IO ()) -> UIBoot
startGtkHook Window -> IO ()
userHook Config
cfg [Event] -> IO ()
ch [Action] -> IO ()
outCh Editor
ed =
  IO (UI Editor) -> (GError -> IO (UI Editor)) -> IO (UI Editor)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((Window -> IO ()) -> UIBoot
startNoMsgGtkHook Window -> IO ()
userHook Config
cfg [Event] -> IO ()
ch [Action] -> IO ()
outCh Editor
ed)
  (\(GError GErrorDomain
_dom Int
_code Text
msg) -> String -> IO (UI Editor)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (UI Editor)) -> String -> IO (UI Editor)
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
msg)

startNoMsgGtkHook :: (Gtk.Window -> IO ()) -> UIBoot
startNoMsgGtkHook :: (Window -> IO ()) -> UIBoot
startNoMsgGtkHook Window -> IO ()
userHook Config
cfg [Event] -> IO ()
ch [Action] -> IO ()
outCh Editor
ed = do
  Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
"startNoMsgGtkHook"
  IO [String] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO [String]
unsafeInitGUIForThreadedRTS

  Window
win   <- IO Window
windowNew
  Pixbuf
ico   <- String -> IO Pixbuf
loadIcon String
"yi+lambda-fat-32.png"
  VBox
vb    <- Bool -> Int -> IO VBox
vBoxNew Bool
False Int
1    -- Top-level vbox

  IMContext
im <- IO IMContext
imMulticontextNew
  IMContext -> Bool -> IO ()
forall self. IMContextClass self => self -> Bool -> IO ()
imContextSetUsePreedit IMContext
im Bool
False  -- handler for preedit string not implemented

  -- Yi.Buffer.Misc.insertN for atomic input?
  let imContextCommitS :: Signal IMContext (String -> IO ())
      imContextCommitS :: Signal IMContext (String -> IO ())
imContextCommitS = Signal IMContext (String -> IO ())
forall self string.
(IMContextClass self, GlibString string) =>
Signal self (string -> IO ())
imContextCommit
  IMContext
im IMContext
-> Signal IMContext (String -> IO ()) -> (String -> IO ()) -> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal IMContext (String -> IO ())
imContextCommitS ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Char -> IO ()) -> String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Char
k -> [Event] -> IO ()
ch [Key -> [Modifier] -> Event
Event (Char -> Key
KASCII Char
k) []])

  Window -> [AttrOp Window] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set Window
win [ Attr Window Int
forall self. WindowClass self => Attr self Int
windowDefaultWidth  Attr Window Int -> Int -> AttrOp Window
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Int
700
          , Attr Window Int
forall self. WindowClass self => Attr self Int
windowDefaultHeight Attr Window Int -> Int -> AttrOp Window
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Int
900
          , Attr Window Text
forall self string.
(WindowClass self, GlibString string) =>
Attr self string
windowTitle         Attr Window Text -> Text -> AttrOp Window
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= (Text
"Yi" :: T.Text)
          , Attr Window (Maybe Pixbuf)
forall self. WindowClass self => Attr self (Maybe Pixbuf)
windowIcon          Attr Window (Maybe Pixbuf) -> Maybe Pixbuf -> AttrOp Window
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Pixbuf -> Maybe Pixbuf
forall a. a -> Maybe a
Just Pixbuf
ico
          , WriteAttr Window VBox
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild      WriteAttr Window VBox -> VBox -> AttrOp Window
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= VBox
vb
          ]

  Window
win Window
-> Signal Window (EventM EAny Bool) -> EventM EAny Bool -> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal Window (EventM EAny Bool)
forall self. WidgetClass self => Signal self (EventM EAny Bool)
deleteEvent (EventM EAny Bool -> IO ()) -> EventM EAny Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> EventM EAny Bool
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO Bool -> EventM EAny Bool) -> IO Bool -> EventM EAny Bool
forall a b. (a -> b) -> a -> b
$ IO ()
mainQuit IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  Window
win Window
-> Signal Window (EventM EKey Bool) -> EventM EKey Bool -> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal Window (EventM EKey Bool)
forall self. WidgetClass self => Signal self (EventM EKey Bool)
keyPressEvent (EventM EKey Bool -> IO ()) -> EventM EKey Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ([Event] -> IO ()) -> IMContext -> EventM EKey Bool
handleKeypress [Event] -> IO ()
ch IMContext
im

  HPaned
paned <- IO HPaned
hPanedNew
  SimpleNotebook
tabs <- IO SimpleNotebook
simpleNotebookNew
  HPaned -> Widget -> IO ()
forall self child.
(PanedClass self, WidgetClass child) =>
self -> child -> IO ()
panedAdd2 HPaned
paned (SimpleNotebook -> Widget
forall w. WidgetLike w => w -> Widget
baseWidget SimpleNotebook
tabs)

  Statusbar
status  <- IO Statusbar
statusbarNew

  -- Allow multiple lines in statusbar, GitHub issue #478
  Statusbar -> IO Box
forall self. StatusbarClass self => self -> IO Box
statusbarGetMessageArea Statusbar
status IO Box -> (Box -> IO [Widget]) -> IO [Widget]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Box -> IO [Widget]
forall self. ContainerClass self => self -> IO [Widget]
containerGetChildren IO [Widget] -> ([Widget] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [Widget
w] -> Label -> Bool -> IO ()
forall self. LabelClass self => self -> Bool -> IO ()
labelSetSingleLineMode (Widget -> Label
forall obj. GObjectClass obj => obj -> Label
castToLabel Widget
w) Bool
False
    [Widget]
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- statusbarGetContextId status "global"

  VBox -> [AttrOp VBox] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set VBox
vb [ WriteAttr VBox HPaned
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr VBox HPaned -> HPaned -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= HPaned
paned
         , WriteAttr VBox Statusbar
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr VBox Statusbar -> Statusbar -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Statusbar
status
         , Statusbar -> Attr VBox Packing
forall self child.
(BoxClass self, WidgetClass child) =>
child -> Attr self Packing
boxChildPacking Statusbar
status Attr VBox Packing -> Packing -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Packing
PackNatural
         ]

  IORef FontDescription
fontRef <- IO FontDescription
fontDescriptionNew IO FontDescription
-> (FontDescription -> IO (IORef FontDescription))
-> IO (IORef FontDescription)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FontDescription -> IO (IORef FontDescription)
forall a. a -> IO (IORef a)
newIORef

  let actionCh :: Action -> IO ()
actionCh = [Action] -> IO ()
outCh ([Action] -> IO ()) -> (Action -> [Action]) -> Action -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> [Action]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return
  IORef TabCache
tc <- TabCache -> IO (IORef TabCache)
forall a. a -> IO (IORef a)
newIORef (TabCache -> IO (IORef TabCache))
-> IO TabCache -> IO (IORef TabCache)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Editor -> (Action -> IO ()) -> IO TabCache
newCache Editor
ed Action -> IO ()
actionCh

  let watchFont :: (FontDescription -> IO b) -> IO b
watchFont = (Text -> IO FontDescription
forall string. GlibString string => string -> IO FontDescription
fontDescriptionFromString (Text
"Monospace 10" :: T.Text) IO FontDescription -> (FontDescription -> IO b) -> IO b
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
  (FontDescription -> IO ()) -> IO ()
forall {b}. (FontDescription -> IO b) -> IO b
watchFont ((FontDescription -> IO ()) -> IO ())
-> (FontDescription -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ UIConfig
-> IORef FontDescription
-> IORef TabCache
-> Statusbar
-> FontDescription
-> IO ()
updateFont (Config -> UIConfig
configUI Config
cfg) IORef FontDescription
fontRef IORef TabCache
tc Statusbar
status

  -- I think this is the correct place to put it...
  Window -> IO ()
userHook Window
win

  -- use our magic threads thingy
  -- http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/
  IO GErrorDomain -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO GErrorDomain -> IO ()) -> IO GErrorDomain -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> Int -> Int -> IO GErrorDomain
timeoutAddFull (IO ()
yield IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Int
priorityDefaultIdle Int
50

  Window -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetShowAll Window
win

  let ui :: UI
ui = Window
-> SimpleNotebook
-> Statusbar
-> IORef TabCache
-> (Action -> IO ())
-> UIConfig
-> IORef FontDescription
-> IMContext
-> UI
UI Window
win SimpleNotebook
tabs Statusbar
status IORef TabCache
tc Action -> IO ()
actionCh (Config -> UIConfig
configUI Config
cfg) IORef FontDescription
fontRef IMContext
im

  -- Keep the current tab focus up to date
  let move :: Int -> PointedList a -> PointedList a
move Int
n PointedList a
pl = PointedList a -> Maybe (PointedList a) -> PointedList a
forall a. a -> Maybe a -> a
fromMaybe PointedList a
pl (Int -> PointedList a -> Maybe (PointedList a)
forall a. Int -> PointedList a -> Maybe (PointedList a)
PL.moveTo Int
n PointedList a
pl)
      runAction :: EditorM () -> IO ()
runAction = UI -> Action -> IO ()
uiActionCh UI
ui (Action -> IO ()) -> (EditorM () -> Action) -> EditorM () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditorM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction
  -- why does this cause a hang without postGUIAsync?
  SimpleNotebook -> (Int -> IO ()) -> IO ()
simpleNotebookOnSwitchPage (UI -> SimpleNotebook
uiNotebook UI
ui) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
n -> IO () -> IO ()
postGUIAsync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    EditorM () -> IO ()
runAction (ASetter Editor Editor (PointedList Tab) (PointedList Tab)
-> (PointedList Tab -> PointedList Tab) -> EditorM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
(%=) ASetter Editor Editor (PointedList Tab) (PointedList Tab)
Lens' Editor (PointedList Tab)
tabsA (Int -> PointedList Tab -> PointedList Tab
forall {a}. Int -> PointedList a -> PointedList a
move Int
n) :: EditorM ())

  UI Editor -> IO (UI Editor)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UI -> UI Editor
mkUI UI
ui)


main :: IO ()
main :: IO ()
main = Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
"GTK main loop running" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
mainGUI

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

-- | Modify GUI and the 'TabCache' to reflect information in 'Editor'.
updateCache :: UI -> Editor -> IO ()
updateCache :: UI -> Editor -> IO ()
updateCache UI
ui Editor
e = do
       TabCache
cache <- IORef TabCache -> IO TabCache
forall a. IORef a -> IO a
readIORef (IORef TabCache -> IO TabCache) -> IORef TabCache -> IO TabCache
forall a b. (a -> b) -> a -> b
$ UI -> IORef TabCache
tabCache UI
ui
       -- convert to a map for convenient lookups
       let cacheMap :: Map Int TabInfo
cacheMap = PointedList (Int, TabInfo) -> Map Int TabInfo
forall (t :: * -> *) k a.
(Foldable t, Ord k) =>
t (k, a) -> Map k a
mapFromFoldable (PointedList (Int, TabInfo) -> Map Int TabInfo)
-> (TabCache -> PointedList (Int, TabInfo))
-> TabCache
-> Map Int TabInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TabInfo -> (Int, TabInfo))
-> TabCache -> PointedList (Int, TabInfo)
forall a b. (a -> b) -> PointedList a -> PointedList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TabInfo
t -> (TabInfo -> Int
coreTabKey TabInfo
t, TabInfo
t)) (TabCache -> Map Int TabInfo) -> TabCache -> Map Int TabInfo
forall a b. (a -> b) -> a -> b
$ TabCache
cache

       -- build the new cache
       TabCache
cache' <- PointedList Tab -> (Tab -> IO TabInfo) -> IO TabCache
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Editor
e Editor
-> Getting (PointedList Tab) Editor (PointedList Tab)
-> PointedList Tab
forall s a. s -> Getting a s a -> a
^. Getting (PointedList Tab) Editor (PointedList Tab)
Lens' Editor (PointedList Tab)
tabsA) ((Tab -> IO TabInfo) -> IO TabCache)
-> (Tab -> IO TabInfo) -> IO TabCache
forall a b. (a -> b) -> a -> b
$ \Tab
tab ->
         case Int -> Map Int TabInfo -> Maybe TabInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Tab -> Int
tkey Tab
tab) Map Int TabInfo
cacheMap of
           Just TabInfo
t -> Editor -> UI -> Tab -> TabInfo -> IO ()
updateTabInfo Editor
e UI
ui Tab
tab TabInfo
t IO () -> IO TabInfo -> IO TabInfo
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TabInfo -> IO TabInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TabInfo
t
           Maybe TabInfo
Nothing -> Editor -> UI -> Tab -> IO TabInfo
newTab Editor
e UI
ui Tab
tab

       -- store the new cache
       IORef TabCache -> TabCache -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (UI -> IORef TabCache
tabCache UI
ui) TabCache
cache'

       -- update the GUI
       SimpleNotebook -> PointedList (Widget, Text) -> IO ()
simpleNotebookSet (UI -> SimpleNotebook
uiNotebook UI
ui)
         (PointedList (Widget, Text) -> IO ())
-> IO (PointedList (Widget, Text)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TabCache
-> (TabInfo -> IO (Widget, Text))
-> IO (PointedList (Widget, Text))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM TabCache
cache' (\TabInfo
t -> (TabInfo -> Widget
tabWidget TabInfo
t,) (Text -> (Widget, Text)) -> IO Text -> IO (Widget, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (TabInfo -> IORef Text
abbrevTitle TabInfo
t))


-- | Modify GUI and given 'TabInfo' to reflect information in 'Tab'.
updateTabInfo :: Editor -> UI -> Tab -> TabInfo -> IO ()
updateTabInfo :: Editor -> UI -> Tab -> TabInfo -> IO ()
updateTabInfo Editor
e UI
ui Tab
tab TabInfo
tabInfo = do
    -- update the window cache
    WindowCache
wCacheOld <- IORef WindowCache -> IO WindowCache
forall a. IORef a -> IO a
readIORef (TabInfo -> IORef WindowCache
windowCache TabInfo
tabInfo)
    WindowCache
wCacheNew <- PointedList (WindowRef, WinInfo) -> WindowCache
forall (t :: * -> *) k a.
(Foldable t, Ord k) =>
t (k, a) -> Map k a
mapFromFoldable (PointedList (WindowRef, WinInfo) -> WindowCache)
-> IO (PointedList (WindowRef, WinInfo)) -> IO WindowCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PointedList Window
-> (Window -> IO (WindowRef, WinInfo))
-> IO (PointedList (WindowRef, WinInfo))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Tab
tab Tab
-> Getting (PointedList Window) Tab (PointedList Window)
-> PointedList Window
forall s a. s -> Getting a s a -> a
^. Getting (PointedList Window) Tab (PointedList Window)
forall (f :: * -> *).
Functor f =>
(PointedList Window -> f (PointedList Window)) -> Tab -> f Tab
tabWindowsA) (\Window
w ->
      case WindowRef -> WindowCache -> Maybe WinInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Window -> WindowRef
wkey Window
w) WindowCache
wCacheOld of
        Just WinInfo
wInfo -> Editor -> UI -> Window -> WinInfo -> IO ()
updateWindow Editor
e UI
ui Window
w WinInfo
wInfo IO () -> IO (WindowRef, WinInfo) -> IO (WindowRef, WinInfo)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (WindowRef, WinInfo) -> IO (WindowRef, WinInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> WindowRef
wkey Window
w, WinInfo
wInfo)
        Maybe WinInfo
Nothing -> (Window -> WindowRef
wkey Window
w,) (WinInfo -> (WindowRef, WinInfo))
-> IO WinInfo -> IO (WindowRef, WinInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Editor -> UI -> Window -> IO WinInfo
newWindow Editor
e UI
ui Window
w)
    IORef WindowCache -> WindowCache -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TabInfo -> IORef WindowCache
windowCache TabInfo
tabInfo) WindowCache
wCacheNew

    -- TODO update renderer, etc?

    let lookupWin :: WindowRef -> WinInfo
lookupWin WindowRef
w = WindowCache
wCacheNew WindowCache -> WindowRef -> WinInfo
forall k a. Ord k => Map k a -> k -> a
M.! WindowRef
w

    -- set layout
    LayoutDisplay -> Layout Widget -> IO ()
layoutDisplaySet (TabInfo -> LayoutDisplay
layoutDisplay TabInfo
tabInfo)
      (Layout Widget -> IO ()) -> (Tab -> Layout Widget) -> Tab -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowRef -> Widget) -> Layout WindowRef -> Layout Widget
forall a b. (a -> b) -> Layout a -> Layout b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinInfo -> Widget
winWidget (WinInfo -> Widget)
-> (WindowRef -> WinInfo) -> WindowRef -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowRef -> WinInfo
lookupWin) (Layout WindowRef -> Layout Widget)
-> (Tab -> Layout WindowRef) -> Tab -> Layout Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tab -> Layout WindowRef
tabLayout (Tab -> IO ()) -> Tab -> IO ()
forall a b. (a -> b) -> a -> b
$ Tab
tab

    -- set minibox
    MiniwindowDisplay -> [Widget] -> IO ()
miniwindowDisplaySet (TabInfo -> MiniwindowDisplay
miniwindowPage TabInfo
tabInfo)
      ([Widget] -> IO ()) -> (Tab -> [Widget]) -> Tab -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window -> Widget) -> [Window] -> [Widget]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WinInfo -> Widget
winWidget (WinInfo -> Widget) -> (Window -> WinInfo) -> Window -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowRef -> WinInfo
lookupWin (WindowRef -> WinInfo)
-> (Window -> WindowRef) -> Window -> WinInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> WindowRef
wkey) ([Window] -> [Widget]) -> (Tab -> [Window]) -> Tab -> [Widget]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tab -> [Window]
tabMiniWindows (Tab -> IO ()) -> Tab -> IO ()
forall a b. (a -> b) -> a -> b
$ Tab
tab

    -- set focus
    Editor -> UI -> TabInfo -> WinInfo -> IO ()
setWindowFocus Editor
e UI
ui TabInfo
tabInfo (WinInfo -> IO ()) -> (Tab -> WinInfo) -> Tab -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowRef -> WinInfo
lookupWin (WindowRef -> WinInfo) -> (Tab -> WindowRef) -> Tab -> WinInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> WindowRef
wkey (Window -> WindowRef) -> (Tab -> Window) -> Tab -> WindowRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tab -> Window
tabFocus (Tab -> IO ()) -> Tab -> IO ()
forall a b. (a -> b) -> a -> b
$ Tab
tab

updateWindow :: Editor -> UI -> Window -> WinInfo -> IO ()
updateWindow :: Editor -> UI -> Window -> WinInfo -> IO ()
updateWindow Editor
e UI
_ui Window
win WinInfo
wInfo = do
    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WinInfo -> IORef Bool
inFocus WinInfo
wInfo) Bool
False -- see also 'setWindowFocus'
    IORef Window -> Window -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WinInfo -> IORef Window
coreWin WinInfo
wInfo) Window
win
    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WinInfo -> IORef Bool
insertingMode WinInfo
wInfo)
      (Window -> FBuffer -> BufferM Bool -> Bool
forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
win (BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win) Editor
e) (BufferM Bool -> Bool) -> BufferM Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Getting Bool FBuffer Bool -> BufferM Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool FBuffer Bool
forall c. HasAttributes c => Lens' c Bool
Lens' FBuffer Bool
insertingA)

setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()
setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()
setWindowFocus Editor
e UI
ui TabInfo
t WinInfo
w = do
  Window
win <- IORef Window -> IO Window
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Window
coreWin WinInfo
w)
  let bufferName :: Text
bufferName = Int -> FBuffer -> Text
shortIdentString ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ Editor -> [String]
commonNamePrefix Editor
e) (FBuffer -> Text) -> FBuffer -> Text
forall a b. (a -> b) -> a -> b
$
                   BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win) Editor
e
      ml :: Text
ml = Window -> FBuffer -> BufferM Text -> Text
forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
win (BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win) Editor
e) (BufferM Text -> Text) -> BufferM Text -> Text
forall a b. (a -> b) -> a -> b
$
           [Text] -> BufferM Text
getModeLine (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Editor -> [String]
commonNamePrefix Editor
e)
      im :: IMContext
im = UI -> IMContext
uiInput UI
ui

  IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WinInfo -> IORef Bool
inFocus WinInfo
w) Bool
True -- see also 'updateWindow'
  DrawingArea -> ReadWriteAttr DrawingArea Bool Bool -> Bool -> IO ()
forall a o. Eq a => o -> ReadWriteAttr o a a -> a -> IO ()
update (WinInfo -> DrawingArea
textview WinInfo
w) ReadWriteAttr DrawingArea Bool Bool
forall self. WidgetClass self => Attr self Bool
widgetIsFocus Bool
True
  Label -> ReadWriteAttr Label Text Text -> Text -> IO ()
forall a o. Eq a => o -> ReadWriteAttr o a a -> a -> IO ()
update (WinInfo -> Label
modeline WinInfo
w) ReadWriteAttr Label Text Text
forall self string.
(LabelClass self, GlibString string) =>
Attr self string
labelText Text
ml
  IORef Text -> Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TabInfo -> IORef Text
fullTitle TabInfo
t) Text
bufferName
  IORef Text -> Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TabInfo -> IORef Text
abbrevTitle TabInfo
t) (Text -> Text
tabAbbrevTitle Text
bufferName)
  Maybe DrawWindow
drawW <- IO (Maybe DrawWindow)
-> (SomeException -> IO (Maybe DrawWindow))
-> IO (Maybe DrawWindow)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((DrawWindow -> Maybe DrawWindow)
-> IO DrawWindow -> IO (Maybe DrawWindow)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DrawWindow -> Maybe DrawWindow
forall a. a -> Maybe a
Just (IO DrawWindow -> IO (Maybe DrawWindow))
-> IO DrawWindow -> IO (Maybe DrawWindow)
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO DrawWindow
forall widget. WidgetClass widget => widget -> IO DrawWindow
widgetGetDrawWindow (DrawingArea -> IO DrawWindow) -> DrawingArea -> IO DrawWindow
forall a b. (a -> b) -> a -> b
$ WinInfo -> DrawingArea
textview WinInfo
w)
                 (\(SomeException
_ :: SomeException) -> Maybe DrawWindow -> IO (Maybe DrawWindow)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DrawWindow
forall a. Maybe a
Nothing)
  IMContext -> Maybe DrawWindow -> IO ()
forall self.
IMContextClass self =>
self -> Maybe DrawWindow -> IO ()
imContextSetClientWindow IMContext
im Maybe DrawWindow
drawW
  IMContext -> IO ()
forall self. IMContextClass self => self -> IO ()
imContextFocusIn IMContext
im

getWinInfo :: UI -> WindowRef -> IO WinInfo
getWinInfo :: UI -> WindowRef -> IO WinInfo
getWinInfo UI
ui WindowRef
ref =
  let tabLoop :: [TabInfo] -> IO WinInfo
tabLoop []     = Text -> IO WinInfo
forall a. Text -> a
error Text
"Yi.UI.Pango.getWinInfo: window not found"
      tabLoop (TabInfo
t:[TabInfo]
ts) = do
        WindowCache
wCache <- IORef WindowCache -> IO WindowCache
forall a. IORef a -> IO a
readIORef (TabInfo -> IORef WindowCache
windowCache TabInfo
t)
        case WindowRef -> WindowCache -> Maybe WinInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WindowRef
ref WindowCache
wCache of
          Just WinInfo
w -> WinInfo -> IO WinInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return WinInfo
w
          Maybe WinInfo
Nothing -> [TabInfo] -> IO WinInfo
tabLoop [TabInfo]
ts
  in IORef TabCache -> IO TabCache
forall a. IORef a -> IO a
readIORef (UI -> IORef TabCache
tabCache UI
ui) IO TabCache -> (TabCache -> IO WinInfo) -> IO WinInfo
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([TabInfo] -> IO WinInfo
tabLoop ([TabInfo] -> IO WinInfo)
-> (TabCache -> [TabInfo]) -> TabCache -> IO WinInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TabCache -> [TabInfo]
forall a. PointedList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)

-- | Make the cache from the editor and the action channel
newCache :: Editor -> (Action -> IO ()) -> IO TabCache
newCache :: Editor -> (Action -> IO ()) -> IO TabCache
newCache Editor
e Action -> IO ()
actionCh = (Tab -> IO TabInfo) -> PointedList Tab -> IO TabCache
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PointedList a -> m (PointedList b)
mapM ((Action -> IO ()) -> Tab -> IO TabInfo
mkDummyTab Action -> IO ()
actionCh) (Editor
e Editor
-> Getting (PointedList Tab) Editor (PointedList Tab)
-> PointedList Tab
forall s a. s -> Getting a s a -> a
^. Getting (PointedList Tab) Editor (PointedList Tab)
Lens' Editor (PointedList Tab)
tabsA)

-- | Make a new tab, and populate it
newTab :: Editor -> UI -> Tab -> IO TabInfo
newTab :: Editor -> UI -> Tab -> IO TabInfo
newTab Editor
e UI
ui Tab
tab = do
  TabInfo
t <- (Action -> IO ()) -> Tab -> IO TabInfo
mkDummyTab (UI -> Action -> IO ()
uiActionCh UI
ui) Tab
tab
  Editor -> UI -> Tab -> TabInfo -> IO ()
updateTabInfo Editor
e UI
ui Tab
tab TabInfo
t
  TabInfo -> IO TabInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TabInfo
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 :: (Action -> IO ()) -> Tab -> IO TabInfo
mkDummyTab Action -> IO ()
actionCh Tab
tab = do
    IORef WindowCache
ws <- WindowCache -> IO (IORef WindowCache)
forall a. a -> IO (IORef a)
newIORef WindowCache
forall k a. Map k a
M.empty
    LayoutDisplay
ld <- IO LayoutDisplay
layoutDisplayNew
    LayoutDisplay -> (Int -> Double -> IO ()) -> IO ()
layoutDisplayOnDividerMove LayoutDisplay
ld ((Action -> IO ()) -> Int -> Double -> IO ()
handleDividerMove Action -> IO ()
actionCh)
    MiniwindowDisplay
mwp <- IO MiniwindowDisplay
miniwindowDisplayNew
    VBox
tw <- Bool -> Int -> IO VBox
vBoxNew Bool
False Int
0
    VBox -> [AttrOp VBox] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set VBox
tw [WriteAttr VBox Widget
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr VBox Widget -> Widget -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= LayoutDisplay -> Widget
forall w. WidgetLike w => w -> Widget
baseWidget LayoutDisplay
ld,
            WriteAttr VBox Widget
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr VBox Widget -> Widget -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= MiniwindowDisplay -> Widget
forall w. WidgetLike w => w -> Widget
baseWidget MiniwindowDisplay
mwp,
            Widget -> Attr VBox Packing
forall self child.
(BoxClass self, WidgetClass child) =>
child -> Attr self Packing
boxChildPacking (LayoutDisplay -> Widget
forall w. WidgetLike w => w -> Widget
baseWidget LayoutDisplay
ld) Attr VBox Packing -> Packing -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Packing
PackGrow,
            Widget -> Attr VBox Packing
forall self child.
(BoxClass self, WidgetClass child) =>
child -> Attr self Packing
boxChildPacking (MiniwindowDisplay -> Widget
forall w. WidgetLike w => w -> Widget
baseWidget MiniwindowDisplay
mwp) Attr VBox Packing -> Packing -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Packing
PackNatural]
    IORef Text
ftRef <- Text -> IO (IORef Text)
forall a. a -> IO (IORef a)
newIORef Text
""
    IORef Text
atRef <- Text -> IO (IORef Text)
forall a. a -> IO (IORef a)
newIORef Text
""
    TabInfo -> IO TabInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
-> LayoutDisplay
-> MiniwindowDisplay
-> Widget
-> IORef WindowCache
-> IORef Text
-> IORef Text
-> TabInfo
TabInfo (Tab -> Int
tkey Tab
tab) LayoutDisplay
ld MiniwindowDisplay
mwp (VBox -> Widget
forall o. WidgetClass o => o -> Widget
toWidget VBox
tw) IORef WindowCache
ws IORef Text
ftRef IORef Text
atRef)


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

    Label
ml <- Maybe Text -> IO Label
forall string. GlibString string => Maybe string -> IO Label
labelNew (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text)
    Label -> Maybe FontDescription -> IO ()
forall self.
WidgetClass self =>
self -> Maybe FontDescription -> IO ()
widgetModifyFont Label
ml (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
f)
    Label -> [AttrOp Label] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set Label
ml [ Attr Label Float
forall self. MiscClass self => Attr self Float
miscXalign Attr Label Float -> Float -> AttrOp Label
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Float
0.01 ] -- so the text is left-justified.

    -- allow the modeline to be covered up, horizontally
    Label -> Int -> Int -> IO ()
forall self. WidgetClass self => self -> Int -> Int -> IO ()
widgetSetSizeRequest Label
ml Int
0 (-Int
1)

    DrawingArea
v <- IO DrawingArea
drawingAreaNew
    DrawingArea -> Maybe FontDescription -> IO ()
forall self.
WidgetClass self =>
self -> Maybe FontDescription -> IO ()
widgetModifyFont DrawingArea
v (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
f)
    DrawingArea -> [EventMask] -> IO ()
forall self. WidgetClass self => self -> [EventMask] -> IO ()
widgetAddEvents DrawingArea
v [EventMask
Button1MotionMask]
    DrawingArea -> StateType -> Color -> IO ()
forall self.
WidgetClass self =>
self -> StateType -> Color -> IO ()
widgetModifyBg DrawingArea
v StateType
StateNormal (Color -> IO ()) -> (UIConfig -> Color) -> UIConfig -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Color -> Color
mkCol Bool
False (Color -> Color) -> (UIConfig -> Color) -> UIConfig -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Color
Yi.Style.background
      (Attributes -> Color)
-> (UIConfig -> Attributes) -> UIConfig -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UIStyle -> Attributes
baseAttributes (UIStyle -> Attributes)
-> (UIConfig -> UIStyle) -> UIConfig -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UIConfig -> UIStyle
configStyle (UIConfig -> IO ()) -> UIConfig -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> UIConfig
uiConfig UI
ui

    ScrolledWindow
sw <- Maybe Adjustment -> Maybe Adjustment -> IO ScrolledWindow
scrolledWindowNew Maybe Adjustment
forall a. Maybe a
Nothing Maybe Adjustment
forall a. Maybe a
Nothing
    ScrolledWindow -> DrawingArea -> IO ()
forall self child.
(ScrolledWindowClass self, WidgetClass child) =>
self -> child -> IO ()
scrolledWindowAddWithViewport ScrolledWindow
sw DrawingArea
v
    ScrolledWindow -> PolicyType -> PolicyType -> IO ()
forall self.
ScrolledWindowClass self =>
self -> PolicyType -> PolicyType -> IO ()
scrolledWindowSetPolicy ScrolledWindow
sw PolicyType
PolicyAutomatic PolicyType
PolicyNever

    Box
box <- if Window -> Bool
isMini Window
w
     then do
      Label
prompt <- Maybe Text -> IO Label
forall string. GlibString string => Maybe string -> IO Label
labelNew (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FBuffer -> Text
miniIdentString FBuffer
b)
      Label -> Maybe FontDescription -> IO ()
forall self.
WidgetClass self =>
self -> Maybe FontDescription -> IO ()
widgetModifyFont Label
prompt (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
f)

      HBox
hb <- Bool -> Int -> IO HBox
hBoxNew Bool
False Int
1
      HBox -> [AttrOp HBox] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set HBox
hb [ WriteAttr HBox Label
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr HBox Label -> Label -> AttrOp HBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Label
prompt,
               WriteAttr HBox ScrolledWindow
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr HBox ScrolledWindow -> ScrolledWindow -> AttrOp HBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= ScrolledWindow
sw,
               Label -> Attr HBox Packing
forall self child.
(BoxClass self, WidgetClass child) =>
child -> Attr self Packing
boxChildPacking Label
prompt Attr HBox Packing -> Packing -> AttrOp HBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Packing
PackNatural,
               ScrolledWindow -> Attr HBox Packing
forall self child.
(BoxClass self, WidgetClass child) =>
child -> Attr self Packing
boxChildPacking ScrolledWindow
sw Attr HBox Packing -> Packing -> AttrOp HBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Packing
PackGrow]

      Box -> IO Box
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HBox -> Box
forall obj. GObjectClass obj => obj -> Box
castToBox HBox
hb)
     else do
      VBox
vb <- Bool -> Int -> IO VBox
vBoxNew Bool
False Int
1
      VBox -> [AttrOp VBox] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set VBox
vb [ WriteAttr VBox ScrolledWindow
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr VBox ScrolledWindow -> ScrolledWindow -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= ScrolledWindow
sw,
               WriteAttr VBox Label
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr VBox Label -> Label -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Label
ml,
               Label -> Attr VBox Packing
forall self child.
(BoxClass self, WidgetClass child) =>
child -> Attr self Packing
boxChildPacking Label
ml Attr VBox Packing -> Packing -> AttrOp VBox
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Packing
PackNatural]
      Box -> IO Box
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (VBox -> Box
forall obj. GObjectClass obj => obj -> Box
castToBox VBox
vb)

    IORef Point
tosRef    <- Point -> IO (IORef Point)
forall a. a -> IO (IORef a)
newIORef (Window -> FBuffer -> BufferM Point -> Point
forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
w FBuffer
b (Getting Point FBuffer Point -> BufferM Point
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting Point FBuffer Point -> BufferM Point)
-> (Mark -> Getting Point FBuffer Point) -> Mark -> BufferM Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mark -> Getting Point FBuffer Point
forall (f :: * -> *).
Functor f =>
Mark -> (Point -> f Point) -> FBuffer -> f FBuffer
markPointA
                                          (Mark -> BufferM Point) -> BufferM Mark -> BufferM Point
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MarkSet Mark -> Mark
forall a. MarkSet a -> a
fromMark (MarkSet Mark -> Mark) -> BufferM (MarkSet Mark) -> BufferM Mark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufferM (MarkSet Mark)
askMarks))
    PangoContext
context   <- DrawingArea -> IO PangoContext
forall self. WidgetClass self => self -> IO PangoContext
widgetCreatePangoContext DrawingArea
v
    PangoLayout
layout    <- PangoContext -> IO PangoLayout
layoutEmpty PangoContext
context
    MVar WinLayoutInfo
layoutRef <- WinLayoutInfo -> IO (MVar WinLayoutInfo)
forall a. a -> IO (MVar a)
newMVar (PangoLayout
-> Point
-> Point
-> Point
-> Point
-> FBuffer
-> Maybe SearchExp
-> WinLayoutInfo
WinLayoutInfo PangoLayout
layout Point
0 Point
0 Point
0 Point
0
                          (BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
w) Editor
e) Maybe SearchExp
forall a. Maybe a
Nothing)
    Language
language  <- PangoContext -> IO Language
contextGetLanguage PangoContext
context
    FontMetrics
metrics   <- PangoContext -> FontDescription -> Language -> IO FontMetrics
contextGetMetrics PangoContext
context FontDescription
f Language
language
    IORef Bool
ifLButton <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    IORef Bool
imode     <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    IORef Bool
focused   <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    IORef Window
winRef    <- Window -> IO (IORef Window)
forall a. a -> IO (IORef a)
newIORef Window
w

    PangoLayout -> Maybe FontDescription -> IO ()
layoutSetFontDescription PangoLayout
layout (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
f)

    -- stops layoutGetText crashing (as of gtk2hs 0.10.1)
    PangoLayout -> Text -> IO ()
forall string. GlibString string => PangoLayout -> string -> IO ()
layoutSetText PangoLayout
layout Text
T.empty

    let ref :: WindowRef
ref = Window -> WindowRef
wkey Window
w
        win :: WinInfo
win = WinInfo { coreWinKey :: WindowRef
coreWinKey = WindowRef
ref
                      , coreWin :: IORef Window
coreWin   = IORef Window
winRef
                      , winLayoutInfo :: MVar WinLayoutInfo
winLayoutInfo = MVar WinLayoutInfo
layoutRef
                      , winMetrics :: FontMetrics
winMetrics = FontMetrics
metrics
                      , textview :: DrawingArea
textview  = DrawingArea
v
                      , modeline :: Label
modeline  = Label
ml
                      , winWidget :: Widget
winWidget = Box -> Widget
forall o. WidgetClass o => o -> Widget
toWidget Box
box
                      , shownTos :: IORef Point
shownTos  = IORef Point
tosRef
                      , lButtonPressed :: IORef Bool
lButtonPressed = IORef Bool
ifLButton
                      , insertingMode :: IORef Bool
insertingMode = IORef Bool
imode
                      , inFocus :: IORef Bool
inFocus = IORef Bool
focused
                      }
    Editor -> UI -> Window -> WinInfo -> IO ()
updateWindow Editor
e UI
ui Window
w WinInfo
win

    DrawingArea
v DrawingArea
-> Signal DrawingArea (EventM EButton Bool)
-> EventM EButton Bool
-> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal DrawingArea (EventM EButton Bool)
forall self. WidgetClass self => Signal self (EventM EButton Bool)
buttonPressEvent   (EventM EButton Bool -> IO ()) -> EventM EButton Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> WindowRef -> EventM EButton Bool
handleButtonClick   UI
ui WindowRef
ref
    DrawingArea
v DrawingArea
-> Signal DrawingArea (EventM EButton Bool)
-> EventM EButton Bool
-> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal DrawingArea (EventM EButton Bool)
forall self. WidgetClass self => Signal self (EventM EButton Bool)
buttonReleaseEvent (EventM EButton Bool -> IO ()) -> EventM EButton Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> WinInfo -> EventM EButton Bool
handleButtonRelease UI
ui WinInfo
win
    DrawingArea
v DrawingArea
-> Signal DrawingArea (EventM EScroll Bool)
-> EventM EScroll Bool
-> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal DrawingArea (EventM EScroll Bool)
forall self. WidgetClass self => Signal self (EventM EScroll Bool)
scrollEvent        (EventM EScroll Bool -> IO ()) -> EventM EScroll Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> WinInfo -> EventM EScroll Bool
handleScroll        UI
ui WinInfo
win

    -- todo: allocate event rather than configure?
    DrawingArea
v DrawingArea
-> Signal DrawingArea (EventM EConfigure Bool)
-> EventM EConfigure Bool
-> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal DrawingArea (EventM EConfigure Bool)
forall self.
WidgetClass self =>
Signal self (EventM EConfigure Bool)
configureEvent     (EventM EConfigure Bool -> IO ())
-> EventM EConfigure Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> EventM EConfigure Bool
handleConfigure     UI
ui

    DrawingArea
v DrawingArea
-> Signal DrawingArea (EventM EMotion Bool)
-> EventM EMotion Bool
-> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal DrawingArea (EventM EMotion Bool)
forall self. WidgetClass self => Signal self (EventM EMotion Bool)
motionNotifyEvent  (EventM EMotion Bool -> IO ()) -> EventM EMotion Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> WinInfo -> EventM EMotion Bool
handleMove          UI
ui WinInfo
win
    IO (ConnectId DrawingArea) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ConnectId DrawingArea) -> IO ())
-> IO (ConnectId DrawingArea) -> IO ()
forall a b. (a -> b) -> a -> b
$ DrawingArea
v DrawingArea -> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall w.
WidgetClass w =>
w -> (Event -> IO Bool) -> IO (ConnectId w)
`onExpose` UI -> WinInfo -> Event -> IO Bool
forall t. UI -> WinInfo -> t -> IO Bool
render UI
ui WinInfo
win
    -- also redraw when the window receives/loses focus
    UI -> Window
uiWindow UI
ui Window
-> Signal Window (EventM EFocus Bool)
-> EventM EFocus Bool
-> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal Window (EventM EFocus Bool)
forall self. WidgetClass self => Signal self (EventM EFocus Bool)
focusInEvent (EventM EFocus Bool -> IO ()) -> EventM EFocus Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT (Ptr EFocus) IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw DrawingArea
v) ReaderT (Ptr EFocus) IO ()
-> EventM EFocus Bool -> EventM EFocus Bool
forall a b.
ReaderT (Ptr EFocus) IO a
-> ReaderT (Ptr EFocus) IO b -> ReaderT (Ptr EFocus) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> EventM EFocus Bool
forall a. a -> ReaderT (Ptr EFocus) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    UI -> Window
uiWindow UI
ui Window
-> Signal Window (EventM EFocus Bool)
-> EventM EFocus Bool
-> IO ()
forall object callback.
object -> Signal object callback -> callback -> IO ()
`on` Signal Window (EventM EFocus Bool)
forall self. WidgetClass self => Signal self (EventM EFocus Bool)
focusOutEvent (EventM EFocus Bool -> IO ()) -> EventM EFocus Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT (Ptr EFocus) IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw DrawingArea
v) ReaderT (Ptr EFocus) IO ()
-> EventM EFocus Bool -> EventM EFocus Bool
forall a b.
ReaderT (Ptr EFocus) IO a
-> ReaderT (Ptr EFocus) IO b -> ReaderT (Ptr EFocus) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> EventM EFocus Bool
forall a. a -> ReaderT (Ptr EFocus) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    -- todo: consider adding an 'isDirty' flag to WinLayoutInfo,
    -- so that we don't have to recompute the Attributes when focus changes.
    WinInfo -> IO WinInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return WinInfo
win

refresh :: UI -> Editor -> IO ()
refresh :: UI -> Editor -> IO ()
refresh UI
ui Editor
e = do
    IO () -> IO ()
postGUIAsync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
       GErrorDomain
contextId <- Statusbar -> Text -> IO GErrorDomain
forall self string.
(StatusbarClass self, GlibString string) =>
self -> string -> IO GErrorDomain
statusbarGetContextId (UI -> Statusbar
uiStatusbar UI
ui) (Text
"global" :: T.Text)
       Statusbar -> GErrorDomain -> IO ()
forall self. StatusbarClass self => self -> GErrorDomain -> IO ()
statusbarPop  (UI -> Statusbar
uiStatusbar UI
ui) GErrorDomain
contextId
       IO MessageId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO MessageId -> IO ()) -> IO MessageId -> IO ()
forall a b. (a -> b) -> a -> b
$ Statusbar -> GErrorDomain -> Text -> IO MessageId
forall self string.
(StatusbarClass self, GlibString string) =>
self -> GErrorDomain -> string -> IO MessageId
statusbarPush (UI -> Statusbar
uiStatusbar UI
ui) GErrorDomain
contextId (Text -> IO MessageId) -> Text -> IO MessageId
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"  " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
         Editor -> [Text]
statusLine Editor
e

    UI -> Editor -> IO ()
updateCache UI
ui Editor
e -- The cursor may have changed since doLayout
    TabCache
cache <- IORef TabCache -> IO TabCache
forall a. IORef a -> IO a
readIORef (IORef TabCache -> IO TabCache) -> IORef TabCache -> IO TabCache
forall a b. (a -> b) -> a -> b
$ UI -> IORef TabCache
tabCache UI
ui
    TabCache -> (TabInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ TabCache
cache ((TabInfo -> IO ()) -> IO ()) -> (TabInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TabInfo
t -> do
        WindowCache
wCache <- IORef WindowCache -> IO WindowCache
forall a. IORef a -> IO a
readIORef (TabInfo -> IORef WindowCache
windowCache TabInfo
t)
        WindowCache -> (WinInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ WindowCache
wCache ((WinInfo -> IO ()) -> IO ()) -> (WinInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WinInfo
w -> do
            Editor -> UI -> WinInfo -> IO ()
updateWinInfoForRendering Editor
e UI
ui WinInfo
w
            DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw (WinInfo -> DrawingArea
textview WinInfo
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 :: Editor -> UI -> WinInfo -> IO ()
updateWinInfoForRendering Editor
e UI
_ui WinInfo
w = MVar WinLayoutInfo -> (WinLayoutInfo -> IO WinLayoutInfo) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (WinInfo -> MVar WinLayoutInfo
winLayoutInfo WinInfo
w) ((WinLayoutInfo -> IO WinLayoutInfo) -> IO ())
-> (WinLayoutInfo -> IO WinLayoutInfo) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WinLayoutInfo
wli -> do
  Window
win <- IORef Window -> IO Window
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Window
coreWin WinInfo
w)
  WinLayoutInfo -> IO WinLayoutInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WinLayoutInfo -> IO WinLayoutInfo)
-> WinLayoutInfo -> IO WinLayoutInfo
forall a b. (a -> b) -> a -> b
$! WinLayoutInfo
wli{buffer :: FBuffer
buffer=BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win) Editor
e,regex :: Maybe SearchExp
regex=Editor -> Maybe SearchExp
currentRegex Editor
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 :: forall t. UI -> WinInfo -> t -> IO Bool
render UI
ui WinInfo
w t
_event =
  MVar WinLayoutInfo -> (WinLayoutInfo -> IO Bool) -> IO Bool
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (WinInfo -> MVar WinLayoutInfo
winLayoutInfo WinInfo
w) ((WinLayoutInfo -> IO Bool) -> IO Bool)
-> (WinLayoutInfo -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$
  \WinLayoutInfo{winLayout :: WinLayoutInfo -> PangoLayout
winLayout=PangoLayout
layout,Point
tos :: WinLayoutInfo -> Point
tos :: Point
tos,Point
bos :: WinLayoutInfo -> Point
bos :: Point
bos,Point
cur :: WinLayoutInfo -> Point
cur :: Point
cur,buffer :: WinLayoutInfo -> FBuffer
buffer=FBuffer
b,Maybe SearchExp
regex :: WinLayoutInfo -> Maybe SearchExp
regex :: Maybe SearchExp
regex} -> do
    -- read the information
    Window
win <- IORef Window -> IO Window
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Window
coreWin WinInfo
w)

    -- add color attributes.
    let picture :: [(Point, Attributes)]
picture = Window
-> FBuffer
-> BufferM [(Point, Attributes)]
-> [(Point, Attributes)]
forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
win FBuffer
b (BufferM [(Point, Attributes)] -> [(Point, Attributes)])
-> BufferM [(Point, Attributes)] -> [(Point, Attributes)]
forall a b. (a -> b) -> a -> b
$ UIStyle
-> Maybe SearchExp -> Region -> BufferM [(Point, Attributes)]
attributesPictureAndSelB UIStyle
sty Maybe SearchExp
regex
                  (Point -> Point -> Region
mkRegion Point
tos Point
bos)
        sty :: UIStyle
sty = UIConfig -> UIStyle
configStyle (UIConfig -> UIStyle) -> UIConfig -> UIStyle
forall a b. (a -> b) -> a -> b
$ UI -> UIConfig
uiConfig UI
ui

        picZip :: [((Point, Attributes), Point)]
picZip = [(Point, Attributes)] -> [Point] -> [((Point, Attributes), Point)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Point, Attributes)]
picture ([Point] -> [((Point, Attributes), Point)])
-> [Point] -> [((Point, Attributes), Point)]
forall a b. (a -> b) -> a -> b
$ Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
drop Int
1 ((Point, Attributes) -> Point
forall a b. (a, b) -> a
fst ((Point, Attributes) -> Point) -> [(Point, Attributes)] -> [Point]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Point, Attributes)]
picture) [Point] -> [Point] -> [Point]
forall a. Semigroup a => a -> a -> a
<> [Point
bos]
        strokes :: [(Point, Attributes, Point)]
strokes = [ (Point
start',Attributes
s,Point
end') | ((Point
start', Attributes
s), Point
end') <- [((Point, Attributes), Point)]
picZip
                                    , Attributes
s Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
/= Attributes
emptyAttributes ]

        rel :: Point -> b
rel Point
p = Point -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Point
p Point -> Point -> Point
forall a. Num a => a -> a -> a
- Point
tos)
        allAttrs :: [PangoAttribute]
allAttrs = [[PangoAttribute]] -> [PangoAttribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PangoAttribute]] -> [PangoAttribute])
-> [[PangoAttribute]] -> [PangoAttribute]
forall a b. (a -> b) -> a -> b
$ do
          (Point
p1, Attributes Color
fg Color
bg Bool
_rv Bool
bd Bool
itlc Bool
udrl, Point
p2) <- [(Point, Attributes, Point)]
strokes
          let atr :: (t -> t -> t) -> t
atr t -> t -> t
x = t -> t -> t
x (Point -> t
forall {b}. Num b => Point -> b
rel Point
p1) (Point -> t
forall {b}. Num b => Point -> b
rel Point
p2)
              if' :: Bool -> p -> p -> p
if' Bool
p p
x p
y = if Bool
p then p
x else p
y
          [PangoAttribute] -> [[PangoAttribute]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Int -> Int -> Color -> PangoAttribute) -> Color -> PangoAttribute
forall {t} {t} {t}. (Num t, Num t) => (t -> t -> t) -> t
atr Int -> Int -> Color -> PangoAttribute
AttrForeground (Color -> PangoAttribute) -> Color -> PangoAttribute
forall a b. (a -> b) -> a -> b
$ Bool -> Color -> Color
mkCol Bool
True Color
fg
                 , (Int -> Int -> Color -> PangoAttribute) -> Color -> PangoAttribute
forall {t} {t} {t}. (Num t, Num t) => (t -> t -> t) -> t
atr Int -> Int -> Color -> PangoAttribute
AttrBackground (Color -> PangoAttribute) -> Color -> PangoAttribute
forall a b. (a -> b) -> a -> b
$ Bool -> Color -> Color
mkCol Bool
False Color
bg
                 , (Int -> Int -> FontStyle -> PangoAttribute)
-> FontStyle -> PangoAttribute
forall {t} {t} {t}. (Num t, Num t) => (t -> t -> t) -> t
atr Int -> Int -> FontStyle -> PangoAttribute
AttrStyle (FontStyle -> PangoAttribute) -> FontStyle -> PangoAttribute
forall a b. (a -> b) -> a -> b
$ Bool -> FontStyle -> FontStyle -> FontStyle
forall {p}. Bool -> p -> p -> p
if' Bool
itlc FontStyle
StyleItalic FontStyle
StyleNormal
                 , (Int -> Int -> Underline -> PangoAttribute)
-> Underline -> PangoAttribute
forall {t} {t} {t}. (Num t, Num t) => (t -> t -> t) -> t
atr Int -> Int -> Underline -> PangoAttribute
AttrUnderline (Underline -> PangoAttribute) -> Underline -> PangoAttribute
forall a b. (a -> b) -> a -> b
$ Bool -> Underline -> Underline -> Underline
forall {p}. Bool -> p -> p -> p
if' Bool
udrl Underline
UnderlineSingle Underline
UnderlineNone
                 , (Int -> Int -> Weight -> PangoAttribute)
-> Weight -> PangoAttribute
forall {t} {t} {t}. (Num t, Num t) => (t -> t -> t) -> t
atr Int -> Int -> Weight -> PangoAttribute
AttrWeight (Weight -> PangoAttribute) -> Weight -> PangoAttribute
forall a b. (a -> b) -> a -> b
$ Bool -> Weight -> Weight -> Weight
forall {p}. Bool -> p -> p -> p
if' Bool
bd Weight
WeightBold Weight
WeightNormal
                 ]

    PangoLayout -> [PangoAttribute] -> IO ()
layoutSetAttributes PangoLayout
layout [PangoAttribute]
allAttrs

    DrawWindow
drawWindow <- DrawingArea -> IO DrawWindow
forall widget. WidgetClass widget => widget -> IO DrawWindow
widgetGetDrawWindow (DrawingArea -> IO DrawWindow) -> DrawingArea -> IO DrawWindow
forall a b. (a -> b) -> a -> b
$ WinInfo -> DrawingArea
textview WinInfo
w
    GC
gc <- DrawWindow -> IO GC
forall d. DrawableClass d => d -> IO GC
gcNew DrawWindow
drawWindow

    -- see Note [PangoLayout width]
    -- draw the layout
    DrawWindow -> GC -> Int -> Int -> PangoLayout -> IO ()
forall d.
DrawableClass d =>
d -> GC -> Int -> Int -> PangoLayout -> IO ()
drawLayout DrawWindow
drawWindow GC
gc Int
1 Int
0 PangoLayout
layout

    -- calculate the cursor position
    Bool
im <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Bool
insertingMode WinInfo
w)

    -- check focus, and decide whether we want a wide cursor
    Bool
bufferFocused <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Bool
inFocus WinInfo
w)
    Bool
uiFocused <- Window -> IO Bool
forall self. WindowClass self => self -> IO Bool
Gtk.windowHasToplevelFocus (UI -> Window
uiWindow UI
ui)
    let focused :: Bool
focused = Bool
bufferFocused Bool -> Bool -> Bool
&& Bool
uiFocused
        wideCursor :: Bool
wideCursor =
         case UIConfig -> CursorStyle
configCursorStyle (UI -> UIConfig
uiConfig UI
ui) of
           CursorStyle
AlwaysFat -> Bool
True
           CursorStyle
NeverFat -> Bool
False
           CursorStyle
FatWhenFocused -> Bool
focused
           CursorStyle
FatWhenFocusedAndInserting -> Bool
focused Bool -> Bool -> Bool
&& Bool
im


    (PangoRectangle (Double -> Double
forall a. Enum a => a -> a
succ -> Double
curX) Double
curY Double
curW Double
curH, PangoRectangle
_) <-
      PangoLayout -> Int -> IO (PangoRectangle, PangoRectangle)
layoutGetCursorPos PangoLayout
layout (Point -> Int
forall {b}. Num b => Point -> b
rel Point
cur)
    -- tell the input method
    IMContext -> Rectangle -> IO ()
forall self. IMContextClass self => self -> Rectangle -> IO ()
imContextSetCursorLocation (UI -> IMContext
uiInput UI
ui) (Rectangle -> IO ()) -> Rectangle -> IO ()
forall a b. (a -> b) -> a -> b
$
      Int -> Int -> Int -> Int -> Rectangle
Rectangle (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
curX) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
curY) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
curW) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
curH)
    -- paint the cursor
    GC -> GCValues -> IO ()
gcSetValues GC
gc
      (GCValues
newGCValues { foreground :: Color
Gtk.foreground = Bool -> Color -> Color
mkCol Bool
True (Color -> Color) -> (UIConfig -> Color) -> UIConfig -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Color
Yi.Style.foreground
                                      (Attributes -> Color)
-> (UIConfig -> Attributes) -> UIConfig -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UIStyle -> Attributes
baseAttributes (UIStyle -> Attributes)
-> (UIConfig -> UIStyle) -> UIConfig -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UIConfig -> UIStyle
configStyle (UIConfig -> Color) -> UIConfig -> Color
forall a b. (a -> b) -> a -> b
$
                                      UI -> UIConfig
uiConfig UI
ui
                   , lineWidth :: Int
Gtk.lineWidth = if Bool
wideCursor then Int
2 else Int
1 })

    -- tell the renderer
    if Bool
im
      then  -- if we are inserting, we just want a line
      DrawWindow -> GC -> Point -> Point -> IO ()
forall d. DrawableClass d => d -> GC -> Point -> Point -> IO ()
drawLine DrawWindow
drawWindow GC
gc (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
curX, Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
curY)
      (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
curX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
curW, Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
curY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
curH)

      -- we aren't inserting, we want a rectangle around the current character
      else do
      PangoRectangle (Double -> Double
forall a. Enum a => a -> a
succ -> Double
chx) Double
chy Double
chw Double
chh <- PangoLayout -> Int -> IO PangoRectangle
layoutIndexToPos
                                                  PangoLayout
layout (Point -> Int
forall {b}. Num b => Point -> b
rel Point
cur)
      DrawWindow -> GC -> Bool -> Int -> Int -> Int -> Int -> IO ()
forall d.
DrawableClass d =>
d -> GC -> Bool -> Int -> Int -> Int -> Int -> IO ()
drawRectangle DrawWindow
drawWindow GC
gc Bool
False (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chx) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chy)
        (if Double
chw Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chw else Int
8) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chh)

    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

doLayout :: UI -> Editor -> IO Editor
doLayout :: UI -> Editor -> IO Editor
doLayout UI
ui Editor
e = do
    UI -> Editor -> IO ()
updateCache UI
ui Editor
e
    TabCache
tabs <- IORef TabCache -> IO TabCache
forall a. IORef a -> IO a
readIORef (IORef TabCache -> IO TabCache) -> IORef TabCache -> IO TabCache
forall a b. (a -> b) -> a -> b
$ UI -> IORef TabCache
tabCache UI
ui
    FontDescription
f <- IORef FontDescription -> IO FontDescription
forall a. IORef a -> IO a
readIORef (UI -> IORef FontDescription
uiFont UI
ui)
    Map WindowRef (Int, Int, Region)
dims <- PointedList (Map WindowRef (Int, Int, Region))
-> Map WindowRef (Int, Int, Region)
forall m. Monoid m => PointedList m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (PointedList (Map WindowRef (Int, Int, Region))
 -> Map WindowRef (Int, Int, Region))
-> IO (PointedList (Map WindowRef (Int, Int, Region)))
-> IO (Map WindowRef (Int, Int, Region))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TabInfo -> IO (Map WindowRef (Int, Int, Region)))
-> TabCache -> IO (PointedList (Map WindowRef (Int, Int, Region)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PointedList a -> m (PointedList b)
mapM (UI
-> FontDescription
-> Editor
-> TabInfo
-> IO (Map WindowRef (Int, Int, Region))
getDimensionsInTab UI
ui FontDescription
f Editor
e) TabCache
tabs
    let e' :: Editor
e' = (ASetter Editor Editor (PointedList Tab) (PointedList Tab)
Lens' Editor (PointedList Tab)
tabsA ASetter Editor Editor (PointedList Tab) (PointedList Tab)
-> (PointedList Tab -> PointedList Tab) -> Editor -> Editor
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Tab -> Tab) -> PointedList Tab -> PointedList Tab
forall a b. (a -> b) -> PointedList a -> PointedList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Window -> Window) -> Tab -> Tab
mapWindows Window -> Window
updateWin)) Editor
e
        updateWin :: Window -> Window
updateWin Window
w = case WindowRef
-> Map WindowRef (Int, Int, Region) -> Maybe (Int, Int, Region)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Window -> WindowRef
wkey Window
w) Map WindowRef (Int, Int, Region)
dims of
                          Maybe (Int, Int, Region)
Nothing -> Window
w
                          Just (Int
wi,Int
h,Region
rgn) -> Window
w { width :: Int
width = Int
wi, height :: Int
height = Int
h, winRegion :: Region
winRegion = Region
rgn }

    -- Don't leak references to old Windows
    let forceWin :: b -> Window -> b
forceWin b
x Window
w = Window -> Int
height Window
w Int -> b -> b
forall a b. a -> b -> b
`seq` Window -> Region
winRegion Window
w Region -> b -> b
forall a b. a -> b -> b
`seq` b
x
    Editor -> IO Editor
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Editor -> IO Editor) -> Editor -> IO Editor
forall a b. (a -> b) -> a -> b
$ ((Editor -> Tab -> Editor) -> Editor -> PointedList Tab -> Editor
forall b a. (b -> a -> b) -> b -> PointedList a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Editor -> Tab -> Editor) -> Editor -> PointedList Tab -> Editor)
-> ((Editor -> Window -> Editor) -> Editor -> Tab -> Editor)
-> (Editor -> Window -> Editor)
-> Editor
-> PointedList Tab
-> Editor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Editor -> Window -> Editor) -> Editor -> Tab -> Editor
forall a. (a -> Window -> a) -> a -> Tab -> a
tabFoldl) Editor -> Window -> Editor
forall {b}. b -> Window -> b
forceWin Editor
e' (Editor
e' Editor
-> Getting (PointedList Tab) Editor (PointedList Tab)
-> PointedList Tab
forall s a. s -> Getting a s a -> a
^. Getting (PointedList Tab) Editor (PointedList Tab)
Lens' Editor (PointedList Tab)
tabsA)

-- | Width, Height
getDimensionsInTab :: UI -> FontDescription -> Editor
                -> TabInfo -> IO (M.Map WindowRef (Int,Int,Region))
getDimensionsInTab :: UI
-> FontDescription
-> Editor
-> TabInfo
-> IO (Map WindowRef (Int, Int, Region))
getDimensionsInTab UI
ui FontDescription
f Editor
e TabInfo
tab = do
  WindowCache
wCache <- IORef WindowCache -> IO WindowCache
forall a. IORef a -> IO a
readIORef (TabInfo -> IORef WindowCache
windowCache TabInfo
tab)
  WindowCache
-> (WinInfo -> IO (Int, Int, Region))
-> IO (Map WindowRef (Int, Int, Region))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM WindowCache
wCache ((WinInfo -> IO (Int, Int, Region))
 -> IO (Map WindowRef (Int, Int, Region)))
-> (WinInfo -> IO (Int, Int, Region))
-> IO (Map WindowRef (Int, Int, Region))
forall a b. (a -> b) -> a -> b
$ \WinInfo
wi -> do
    (Int
wid, Int
h) <- DrawingArea -> IO Point
forall widget. WidgetClass widget => widget -> IO Point
widgetGetSize (DrawingArea -> IO Point) -> DrawingArea -> IO Point
forall a b. (a -> b) -> a -> b
$ WinInfo -> DrawingArea
textview WinInfo
wi
    Window
win <- IORef Window -> IO Window
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Window
coreWin WinInfo
wi)
    let metrics :: FontMetrics
metrics = WinInfo -> FontMetrics
winMetrics WinInfo
wi
        lineHeight :: Double
lineHeight = FontMetrics -> Double
ascent FontMetrics
metrics Double -> Double -> Double
forall a. Num a => a -> a -> a
+ FontMetrics -> Double
descent FontMetrics
metrics
        charWidth :: Double
charWidth = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (FontMetrics -> Double
approximateCharWidth FontMetrics
metrics) (FontMetrics -> Double
approximateDigitWidth FontMetrics
metrics)
        width :: Int
width = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wid Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
charWidth Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1
        height :: Int
height = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lineHeight
        b0 :: FBuffer
b0 = BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win) Editor
e
    Region
rgn <- UI -> FontDescription -> WinInfo -> FBuffer -> IO Region
shownRegion UI
ui FontDescription
f WinInfo
wi FBuffer
b0
    (Int, Int, Region) -> IO (Int, Int, Region)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
width, Int
height, Region
rgn)

shownRegion :: UI -> FontDescription -> WinInfo -> FBuffer -> IO Region
shownRegion :: UI -> FontDescription -> WinInfo -> FBuffer -> IO Region
shownRegion UI
ui FontDescription
f WinInfo
w FBuffer
b = MVar WinLayoutInfo
-> (WinLayoutInfo -> IO (WinLayoutInfo, Region)) -> IO Region
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (WinInfo -> MVar WinLayoutInfo
winLayoutInfo WinInfo
w) ((WinLayoutInfo -> IO (WinLayoutInfo, Region)) -> IO Region)
-> (WinLayoutInfo -> IO (WinLayoutInfo, Region)) -> IO Region
forall a b. (a -> b) -> a -> b
$ \WinLayoutInfo
wli -> do
   (Point
tos, Point
cur, Point
bos, Point
bufEnd) <- UI
-> FontDescription
-> WinInfo
-> FBuffer
-> PangoLayout
-> IO (Point, Point, Point, Point)
updatePango UI
ui FontDescription
f WinInfo
w FBuffer
b (WinLayoutInfo -> PangoLayout
winLayout WinLayoutInfo
wli)
   (WinLayoutInfo, Region) -> IO (WinLayoutInfo, Region)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WinLayoutInfo
wli{Point
tos :: Point
tos :: Point
tos,cur :: Point
cur=Point -> Point -> Point -> Point
forall {a}. Ord a => a -> a -> a -> a
clampTo Point
tos Point
bos Point
cur,Point
bos :: Point
bos :: Point
bos,Point
bufEnd :: Point
bufEnd :: Point
bufEnd}, Point -> Point -> Region
mkRegion Point
tos Point
bos)
 where clampTo :: a -> a -> a -> a
clampTo a
lo a
hi a
x = a -> a -> a
forall a. Ord a => a -> a -> a
max a
lo (a -> a -> a
forall a. Ord a => a -> a -> a
min a
hi a
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
-> FontDescription
-> WinInfo
-> FBuffer
-> PangoLayout
-> IO (Point, Point, Point, Point)
updatePango UI
ui FontDescription
font WinInfo
w FBuffer
b PangoLayout
layout = do
  (Int
width_', Int
height') <- DrawingArea -> IO Point
forall widget. WidgetClass widget => widget -> IO Point
widgetGetSize (DrawingArea -> IO Point) -> DrawingArea -> IO Point
forall a b. (a -> b) -> a -> b
$ WinInfo -> DrawingArea
textview WinInfo
w
  let width' :: Int
width' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
width_' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) -- see Note [PangoLayout width]
      fontDescriptionToStringT :: FontDescription -> IO Text
      fontDescriptionToStringT :: FontDescription -> IO Text
fontDescriptionToStringT = FontDescription -> IO Text
forall string. GlibString string => FontDescription -> IO string
fontDescriptionToString

  -- Resize (and possibly copy) the currently used font.
  FontDescription
curFont <- case Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Maybe Int -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UIConfig -> Maybe Int
configFontSize (UI -> UIConfig
uiConfig UI
ui) of
    Maybe Double
Nothing -> FontDescription -> IO FontDescription
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FontDescription
font
    Just Double
defSize -> FontDescription -> IO (Maybe Double)
fontDescriptionGetSize FontDescription
font IO (Maybe Double)
-> (Maybe Double -> IO FontDescription) -> IO FontDescription
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Double
Nothing -> FontDescription -> Double -> IO ()
fontDescriptionSetSize FontDescription
font Double
defSize IO () -> IO FontDescription -> IO FontDescription
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FontDescription -> IO FontDescription
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FontDescription
font
      Just Double
currentSize -> let fsv :: Int
fsv     = Attributes -> Int
fontsizeVariation (Attributes -> Int) -> Attributes -> Int
forall a b. (a -> b) -> a -> b
$ FBuffer -> Attributes
attributes FBuffer
b
                              newSize :: Double
newSize = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fsv Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
defSize) in
        if Double
newSize Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
currentSize
          then FontDescription -> IO FontDescription
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FontDescription
font
          else do
          -- This seems like it would be very expensive but I'm
          -- justifying it with that it only gets ran once per font
          -- size change. If the font size stays the same, we only
          -- enter this once per layout. We're effectivelly copying
          -- the default font for each layout that changes. An
          -- alternative would be to assign each buffer its own font
          -- but that seems a pain to maintain and if the user never
          -- changes font sizes, it's a waste of memory.
          FontDescription
nf <- FontDescription -> IO FontDescription
fontDescriptionCopy FontDescription
font
          FontDescription -> Double -> IO ()
fontDescriptionSetSize FontDescription
nf Double
newSize
          FontDescription -> IO FontDescription
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FontDescription
nf

  Maybe FontDescription
oldFont <- PangoLayout -> IO (Maybe FontDescription)
layoutGetFontDescription PangoLayout
layout
  Maybe Text
oldFontStr <- IO (Maybe Text)
-> (FontDescription -> IO (Maybe Text))
-> Maybe FontDescription
-> IO (Maybe Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing)
                ((Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe Text
forall a. a -> Maybe a
Just (IO Text -> IO (Maybe Text))
-> (FontDescription -> IO Text)
-> FontDescription
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontDescription -> IO Text
fontDescriptionToStringT) Maybe FontDescription
oldFont
  Maybe Text
newFontStr <- Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FontDescription -> IO Text
fontDescriptionToStringT FontDescription
curFont

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text
oldFontStr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
newFontStr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    PangoLayout -> Maybe FontDescription -> IO ()
layoutSetFontDescription PangoLayout
layout (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
curFont)


  Window
win <- IORef Window -> IO Window
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Window
coreWin WinInfo
w)
  let [Double
width'', Double
height''] = (Int -> Double) -> [Int] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int
width', Int
height']
      metrics :: FontMetrics
metrics             = WinInfo -> FontMetrics
winMetrics WinInfo
w
      lineHeight :: Double
lineHeight          = FontMetrics -> Double
ascent FontMetrics
metrics Double -> Double -> Double
forall a. Num a => a -> a -> a
+ FontMetrics -> Double
descent FontMetrics
metrics
      charWidth :: Double
charWidth           = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (FontMetrics -> Double
approximateCharWidth FontMetrics
metrics)
                                (FontMetrics -> Double
approximateDigitWidth FontMetrics
metrics)
      winw :: Int
winw                = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
width'' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
charWidth)
      winh :: Int
winh                = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
height'' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lineHeight)
      maxChars :: Int
maxChars            = Int
winw Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
winh
      conf :: UIConfig
conf                = UI -> UIConfig
uiConfig UI
ui

      (Point
tos, Point
size, Point
point, Text
text) = Window
-> FBuffer
-> BufferM (Point, Point, Point, Text)
-> (Point, Point, Point, Text)
forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
win FBuffer
b (BufferM (Point, Point, Point, Text)
 -> (Point, Point, Point, Text))
-> BufferM (Point, Point, Point, Text)
-> (Point, Point, Point, Text)
forall a b. (a -> b) -> a -> b
$ do
        Point
from     <- Getting Point FBuffer Point -> BufferM Point
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting Point FBuffer Point -> BufferM Point)
-> (Mark -> Getting Point FBuffer Point) -> Mark -> BufferM Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mark -> Getting Point FBuffer Point
forall (f :: * -> *).
Functor f =>
Mark -> (Point -> f Point) -> FBuffer -> f FBuffer
markPointA (Mark -> BufferM Point) -> BufferM Mark -> BufferM Point
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MarkSet Mark -> Mark
forall a. MarkSet a -> a
fromMark (MarkSet Mark -> Mark) -> BufferM (MarkSet Mark) -> BufferM Mark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufferM (MarkSet Mark)
askMarks
        YiString
rope     <- Direction -> Point -> BufferM YiString
streamB Direction
Forward Point
from
        Point
p        <- BufferM Point
pointB
        Point
bufEnd   <- BufferM Point
sizeB
        let content :: YiString
content = UIConfig -> Int -> YiString -> YiString
takeContent UIConfig
conf Int
maxChars (YiString -> YiString)
-> ((YiString, YiString) -> YiString)
-> (YiString, YiString)
-> YiString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (YiString, YiString) -> YiString
forall a b. (a, b) -> a
fst ((YiString, YiString) -> YiString)
-> (YiString, YiString) -> YiString
forall a b. (a -> b) -> a -> b
$ Int -> YiString -> (YiString, YiString)
R.splitAtLine Int
winh YiString
rope

        -- allow BOS offset to be just after the last line
        let addNL :: YiString -> YiString
addNL = if YiString -> Int
R.countNewLines YiString
content Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
winh
                        then YiString -> YiString
forall a. a -> a
id
                        else (YiString -> Char -> YiString
`R.snoc` Char
'\n')
        (Point, Point, Point, Text) -> BufferM (Point, Point, Point, Text)
forall a. a -> BufferM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point
from, Point
bufEnd, Point
p, YiString -> Text
R.toText (YiString -> Text) -> YiString -> Text
forall a b. (a -> b) -> a -> b
$ YiString -> YiString
addNL YiString
content)


  if UIConfig -> Bool
configLineWrap UIConfig
conf
    then PangoLayout -> LayoutWrapMode -> Double -> IO ()
wrapToWidth PangoLayout
layout LayoutWrapMode
WrapAnywhere Double
width''
    else do
    (Rectangle Int
px Int
_py Int
pwidth Int
_pheight, Rectangle
_) <- PangoLayout -> IO (Rectangle, Rectangle)
layoutGetPixelExtents PangoLayout
layout
    DrawingArea -> Int -> Int -> IO ()
forall self. WidgetClass self => self -> Int -> Int -> IO ()
widgetSetSizeRequest (WinInfo -> DrawingArea
textview WinInfo
w) (Int
pxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
pwidth) (-Int
1)

  -- optimize for cursor movement
  Text
oldText <- PangoLayout -> IO Text
forall string. GlibString string => PangoLayout -> IO string
layoutGetText PangoLayout
layout
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
oldText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
text) (PangoLayout -> Text -> IO ()
forall string. GlibString string => PangoLayout -> string -> IO ()
layoutSetText PangoLayout
layout Text
text)

  (Bool
_, Int
bosOffset, Int
_) <- PangoLayout -> Double -> Double -> IO (Bool, Int, Int)
layoutXYToIndex PangoLayout
layout Double
width''
                       (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
winh Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lineHeight Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1)
  (Point, Point, Point, Point) -> IO (Point, Point, Point, Point)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point
tos, Point
point, Point
tos Point -> Point -> Point
forall a. Num a => a -> a -> a
+ Int -> Point
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bosOffset Point -> Point -> Point
forall a. Num a => a -> a -> a
+ Point
1, Point
size)

-- | This is a hack that makes this renderer not suck in the common
-- case. There are two scenarios: we're line wrapping or we're not
-- line wrapping. This function already assumes that the contents
-- given have all the possible lines we can fit on the screen.
--
-- If we are line wrapping then the most text we'll ever need to
-- render is precisely the number of characters that can fit on the
-- screen. If that's the case, that's precisely what we do, truncate
-- up to the point where the text would be off-screen anyway.
--
-- If we aren't line-wrapping then we can't simply truncate at the max
-- number of characters: lines might be really long, but considering
-- we're not truncating, we should still be able to see every single
-- line that can fit on screen up to the screen bound. This suggests
-- that we could simply render each line up to the bound. While this
-- does work wonders for performance and would work regardless whether
-- we're wrapping or not, currently our implementation of the rest of
-- the module depends on all characters used being set into the
-- layout: if we cut some text off, painting strokes on top or going
-- to the end makes for strange effects. So currently we have no
-- choice but to render all characters in the visible lines. If you
-- have really long lines, this will kill the performance.
--
-- So here we implement the hack for the line-wrapping case. Once we
-- fix stroke painting &c, this distinction can be removed and we can
-- simply snip at the screen boundary whether we're wrapping or not
-- which actually results in great performance in the end. Until that
-- happens, only the line-wrapping case doesn't suck. Fortunately it
-- is the default.
takeContent :: UIConfig -> Int -> R.YiString -> R.YiString
takeContent :: UIConfig -> Int -> YiString -> YiString
takeContent UIConfig
cf Int
cl YiString
t = if UIConfig -> Bool
configLineWrap UIConfig
cf
                        then Int -> YiString -> YiString
R.take Int
cl YiString
t
                        else YiString
t

-- | Wraps the layout according to the given 'LayoutWrapMode', using
-- the specified width.
--
-- In contrast to the past, it actually implements wrapping properly
-- which was previously broken.
wrapToWidth :: PangoLayout -> LayoutWrapMode -> Double -> IO ()
wrapToWidth :: PangoLayout -> LayoutWrapMode -> Double -> IO ()
wrapToWidth PangoLayout
l LayoutWrapMode
wm Double
w = do
  PangoLayout -> IO LayoutWrapMode
layoutGetWrap PangoLayout
l IO LayoutWrapMode -> (LayoutWrapMode -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LayoutWrapMode
wr -> case (LayoutWrapMode
wr, LayoutWrapMode
wm) of
    -- No Eq instance…
    (LayoutWrapMode
WrapWholeWords, LayoutWrapMode
WrapWholeWords) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (LayoutWrapMode
WrapAnywhere, LayoutWrapMode
WrapAnywhere) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (LayoutWrapMode
WrapPartialWords, LayoutWrapMode
WrapPartialWords) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (LayoutWrapMode, LayoutWrapMode)
_ -> PangoLayout -> LayoutWrapMode -> IO ()
layoutSetWrap PangoLayout
l LayoutWrapMode
wm

  PangoLayout -> IO (Maybe Double)
layoutGetWidth PangoLayout
l IO (Maybe Double) -> (Maybe Double -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Double
x | Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
w -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Double
_               -> PangoLayout -> Maybe Double -> IO ()
layoutSetWidth PangoLayout
l (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w)

reloadProject :: IO ()
reloadProject :: IO ()
reloadProject = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

mkCol :: Bool -- ^ is foreground?
      -> Yi.Style.Color -> Gtk.Color
mkCol :: Bool -> Color -> Color
mkCol Bool
True  Color
Default = Word16 -> Word16 -> Word16 -> Color
Color Word16
0 Word16
0 Word16
0
mkCol Bool
False Color
Default = Word16 -> Word16 -> Word16 -> Color
Color Word16
forall a. Bounded a => a
maxBound Word16
forall a. Bounded a => a
maxBound Word16
forall a. Bounded a => a
maxBound
mkCol Bool
_ (RGB Word8
x Word8
y Word8
z) = Word16 -> Word16 -> Word16 -> Color
Color (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* Word16
256)
                            (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
y Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* Word16
256)
                            (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
z Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* Word16
256)

-- * GTK Event handlers

-- | Process GTK keypress if IM fails
handleKeypress :: ([Event] -> IO ()) -- ^ Event dispatcher (Yi.Core.dispatch)
               -> IMContext
               -> EventM EKey Bool
handleKeypress :: ([Event] -> IO ()) -> IMContext -> EventM EKey Bool
handleKeypress [Event] -> IO ()
ch IMContext
im = do
  [Modifier]
gtkMods <- EventM EKey [Modifier]
forall t. HasModifier t => EventM t [Modifier]
eventModifier
  KeyVal
gtkKey  <- EventM EKey KeyVal
eventKeyVal
  Bool
ifIM    <- IMContext -> EventM EKey Bool
forall self. IMContextClass self => self -> EventM EKey Bool
imContextFilterKeypress IMContext
im
  let char :: Maybe Char
char = KeyVal -> Maybe Char
keyToChar KeyVal
gtkKey
      modsWithShift :: [Modifier]
modsWithShift = Map Modifier Modifier -> [Modifier]
forall k a. Map k a -> [k]
M.keys (Map Modifier Modifier -> [Modifier])
-> Map Modifier Modifier -> [Modifier]
forall a b. (a -> b) -> a -> b
$ (Modifier -> Bool)
-> Map Modifier Modifier -> Map Modifier Modifier
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Modifier -> [Modifier] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Modifier]
gtkMods) Map Modifier Modifier
modTable
      mods :: [Modifier]
mods | Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust Maybe Char
char = (Modifier -> Bool) -> [Modifier] -> [Modifier]
forall a. (a -> Bool) -> [a] -> [a]
filter (Modifier -> Modifier -> Bool
forall a. Eq a => a -> a -> Bool
/= Modifier
MShift) [Modifier]
modsWithShift
           | Bool
otherwise   = [Modifier]
modsWithShift
      key :: Maybe Key
key  = case Maybe Char
char of
        Just Char
c  -> Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ Char -> Key
KASCII Char
c
        Maybe Char
Nothing -> Text -> Map Text Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyVal -> Text
keyName KeyVal
gtkKey) Map Text Key
keyTable

  case (Bool
ifIM, Maybe Key
key) of
    (Bool
True, Maybe Key
_   ) -> () -> ReaderT (Ptr EKey) IO ()
forall a. a -> ReaderT (Ptr EKey) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Bool
_, Maybe Key
Nothing) -> Text -> ReaderT (Ptr EKey) IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn (Text -> ReaderT (Ptr EKey) IO ())
-> Text -> ReaderT (Ptr EKey) IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Event not translatable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Key -> Text
forall a. Show a => a -> Text
showT Maybe Key
key
    (Bool
_, Just Key
k ) -> IO () -> ReaderT (Ptr EKey) IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO () -> ReaderT (Ptr EKey) IO ())
-> IO () -> ReaderT (Ptr EKey) IO ()
forall a b. (a -> b) -> a -> b
$ [Event] -> IO ()
ch [Key -> [Modifier] -> Event
Event Key
k [Modifier]
mods]
  Bool -> EventM EKey Bool
forall a. a -> ReaderT (Ptr EKey) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

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

handleButtonClick :: UI -> WindowRef -> EventM EButton Bool
handleButtonClick :: UI -> WindowRef -> EventM EButton Bool
handleButtonClick UI
ui WindowRef
ref = do
  (Double
x, Double
y) <- EventM EButton (Double, Double)
forall t. HasCoordinates t => EventM t (Double, Double)
eventCoordinates
  Click
click  <- EventM EButton Click
eventClick
  MouseButton
button <- EventM EButton MouseButton
eventButton
  IO Bool -> EventM EButton Bool
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO Bool -> EventM EButton Bool) -> IO Bool -> EventM EButton Bool
forall a b. (a -> b) -> a -> b
$ do
    WinInfo
w <- UI -> WindowRef -> IO WinInfo
getWinInfo UI
ui WindowRef
ref
    Point
point <- (Double, Double) -> WinInfo -> IO Point
pointToOffset (Double
x, Double
y) WinInfo
w

    let focusWindow :: EditorM ()
focusWindow = WindowRef -> EditorM ()
focusWindowE WindowRef
ref
        runAction :: EditorM () -> IO ()
runAction = UI -> Action -> IO ()
uiActionCh UI
ui (Action -> IO ()) -> (EditorM () -> Action) -> EditorM () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditorM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction

    EditorM () -> IO ()
runAction EditorM ()
focusWindow

    Window
win <- IO Window -> IO Window
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO Window -> IO Window) -> IO Window -> IO Window
forall a b. (a -> b) -> a -> b
$ IORef Window -> IO Window
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Window
coreWin WinInfo
w)

    let selectRegion :: TextUnit -> IO ()
selectRegion TextUnit
tu = EditorM () -> IO ()
runAction (EditorM () -> IO ()) -> EditorM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          BufferRef
b <- (Editor -> BufferRef) -> EditorM BufferRef
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Editor -> BufferRef) -> EditorM BufferRef)
-> (Editor -> BufferRef) -> EditorM BufferRef
forall a b. (a -> b) -> a -> b
$ FBuffer -> BufferRef
bkey (FBuffer -> BufferRef)
-> (Editor -> FBuffer) -> Editor -> BufferRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win)
          Window -> BufferRef -> BufferM () -> EditorM ()
forall (m :: * -> *) a.
MonadEditor m =>
Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow Window
win BufferRef
b (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$
            Point -> BufferM ()
moveTo Point
point BufferM () -> BufferM Region -> BufferM Region
forall a b. BufferM a -> BufferM b -> BufferM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextUnit -> BufferM Region
regionOfB TextUnit
tu BufferM Region -> (Region -> BufferM ()) -> BufferM ()
forall a b. BufferM a -> (a -> BufferM b) -> BufferM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Region -> BufferM ()
setSelectRegionB

    case (Click
click, MouseButton
button) of
      (Click
SingleClick, MouseButton
LeftButton) -> do
        IO () -> IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WinInfo -> IORef Bool
lButtonPressed WinInfo
w) Bool
True
        EditorM () -> IO ()
runAction (EditorM () -> IO ()) -> EditorM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          BufferRef
b <- (Editor -> BufferRef) -> EditorM BufferRef
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Editor -> BufferRef) -> EditorM BufferRef)
-> (Editor -> BufferRef) -> EditorM BufferRef
forall a b. (a -> b) -> a -> b
$ FBuffer -> BufferRef
bkey (FBuffer -> BufferRef)
-> (Editor -> FBuffer) -> Editor -> BufferRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win)
          Window -> BufferRef -> BufferM () -> EditorM ()
forall (m :: * -> *) a.
MonadEditor m =>
Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow Window
win BufferRef
b (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$ do
            Mark
m <- MarkSet Mark -> Mark
forall a. MarkSet a -> a
selMark (MarkSet Mark -> Mark) -> BufferM (MarkSet Mark) -> BufferM Mark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufferM (MarkSet Mark)
askMarks
            Mark -> (Point -> Identity Point) -> FBuffer -> Identity FBuffer
forall (f :: * -> *).
Functor f =>
Mark -> (Point -> f Point) -> FBuffer -> f FBuffer
markPointA Mark
m ((Point -> Identity Point) -> FBuffer -> Identity FBuffer)
-> Point -> BufferM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Point
point
            Point -> BufferM ()
moveTo Point
point
            Bool -> BufferM ()
setVisibleSelection Bool
False
      (Click
DoubleClick, MouseButton
LeftButton) -> TextUnit -> IO ()
selectRegion TextUnit
unitWord
      (Click
TripleClick, MouseButton
LeftButton) -> TextUnit -> IO ()
selectRegion TextUnit
Line
      (Click, MouseButton)
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


handleButtonRelease :: UI -> WinInfo -> EventM EButton Bool
handleButtonRelease :: UI -> WinInfo -> EventM EButton Bool
handleButtonRelease UI
ui WinInfo
w = do
  (Double
x, Double
y)   <- EventM EButton (Double, Double)
forall t. HasCoordinates t => EventM t (Double, Double)
eventCoordinates
  MouseButton
button   <- EventM EButton MouseButton
eventButton
  IO () -> ReaderT (Ptr EButton) IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO () -> ReaderT (Ptr EButton) IO ())
-> IO () -> ReaderT (Ptr EButton) IO ()
forall a b. (a -> b) -> a -> b
$ do
    Point
point <- (Double, Double) -> WinInfo -> IO Point
pointToOffset (Double
x, Double
y) WinInfo
w
    Display
disp  <- DrawingArea -> IO Display
forall self. WidgetClass self => self -> IO Display
widgetGetDisplay (DrawingArea -> IO Display) -> DrawingArea -> IO Display
forall a b. (a -> b) -> a -> b
$ WinInfo -> DrawingArea
textview WinInfo
w
    Clipboard
cb    <- Display -> SelectionTag -> IO Clipboard
clipboardGetForDisplay Display
disp SelectionTag
selectionPrimary
    case MouseButton
button of
         MouseButton
MiddleButton -> UI -> WinInfo -> Point -> Clipboard -> IO ()
pasteSelectionClipboard UI
ui WinInfo
w Point
point Clipboard
cb
         MouseButton
LeftButton   -> UI -> WinInfo -> Clipboard -> IO ()
setSelectionClipboard   UI
ui WinInfo
w Clipboard
cb IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                         IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WinInfo -> IORef Bool
lButtonPressed WinInfo
w) Bool
False
         MouseButton
_            -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool -> EventM EButton Bool
forall a. a -> ReaderT (Ptr EButton) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

handleScroll :: UI -> WinInfo -> EventM EScroll Bool
handleScroll :: UI -> WinInfo -> EventM EScroll Bool
handleScroll UI
ui WinInfo
w = do
  ScrollDirection
scrollDirection <- EventM EScroll ScrollDirection
eventScrollDirection
  (Double, Double)
xy <- EventM EScroll (Double, Double)
forall t. HasCoordinates t => EventM t (Double, Double)
eventCoordinates
  IO () -> ReaderT (Ptr EScroll) IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO () -> ReaderT (Ptr EScroll) IO ())
-> IO () -> ReaderT (Ptr EScroll) IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
ifPressed <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool) -> IORef Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ WinInfo -> IORef Bool
lButtonPressed WinInfo
w
    -- query new coordinates
    let editorAction :: EditorM ()
editorAction =
          BufferM () -> EditorM ()
forall (m :: * -> *) a. MonadEditor m => BufferM a -> m a
withCurrentBuffer (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$ Int -> BufferM ()
scrollB (Int -> BufferM ()) -> Int -> BufferM ()
forall a b. (a -> b) -> a -> b
$ case ScrollDirection
scrollDirection of
            ScrollDirection
ScrollUp   -> Int -> Int
forall a. Num a => a -> a
negate Int
configAmount
            ScrollDirection
ScrollDown -> Int
configAmount
            ScrollDirection
_          -> Int
0 -- Left/right scrolling not supported
        configAmount :: Int
configAmount = UIConfig -> Int
configScrollWheelAmount (UIConfig -> Int) -> UIConfig -> Int
forall a b. (a -> b) -> a -> b
$ UI -> UIConfig
uiConfig UI
ui
    UI -> Action -> IO ()
uiActionCh UI
ui (EditorM () -> Action
forall a. Show a => EditorM a -> Action
EditorA EditorM ()
editorAction)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ifPressed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> WinInfo -> (Double, Double) -> IO ()
selectArea UI
ui WinInfo
w (Double, Double)
xy
  Bool -> EventM EScroll Bool
forall a. a -> ReaderT (Ptr EScroll) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

handleConfigure :: UI -> EventM EConfigure Bool
handleConfigure :: UI -> EventM EConfigure Bool
handleConfigure UI
ui = do
  -- trigger a layout
  -- why does this cause a hang without postGUIAsync?
  IO () -> ReaderT (Ptr EConfigure) IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO () -> ReaderT (Ptr EConfigure) IO ())
-> IO () -> ReaderT (Ptr EConfigure) IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
postGUIAsync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UI -> Action -> IO ()
uiActionCh UI
ui (EditorM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction (() -> EditorM ()
forall a. a -> EditorM a
forall (m :: * -> *) a. Monad m => a -> m a
return () :: EditorM()))
  Bool -> EventM EConfigure Bool
forall a. a -> ReaderT (Ptr EConfigure) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- allow event to be propagated

handleMove :: UI -> WinInfo -> EventM EMotion Bool
handleMove :: UI -> WinInfo -> EventM EMotion Bool
handleMove UI
ui WinInfo
w = EventM EMotion (Double, Double)
forall t. HasCoordinates t => EventM t (Double, Double)
eventCoordinates EventM EMotion (Double, Double)
-> ((Double, Double) -> ReaderT (Ptr EMotion) IO ())
-> ReaderT (Ptr EMotion) IO ()
forall a b.
ReaderT (Ptr EMotion) IO a
-> (a -> ReaderT (Ptr EMotion) IO b) -> ReaderT (Ptr EMotion) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO () -> ReaderT (Ptr EMotion) IO ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO () -> ReaderT (Ptr EMotion) IO ())
-> ((Double, Double) -> IO ())
-> (Double, Double)
-> ReaderT (Ptr EMotion) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UI -> WinInfo -> (Double, Double) -> IO ()
selectArea UI
ui WinInfo
w) ReaderT (Ptr EMotion) IO ()
-> EventM EMotion Bool -> EventM EMotion Bool
forall a b.
ReaderT (Ptr EMotion) IO a
-> ReaderT (Ptr EMotion) IO b -> ReaderT (Ptr EMotion) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                  Bool -> EventM EMotion Bool
forall a. a -> ReaderT (Ptr EMotion) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

handleDividerMove :: (Action -> IO ()) -> DividerRef -> DividerPosition -> IO ()
handleDividerMove :: (Action -> IO ()) -> Int -> Double -> IO ()
handleDividerMove Action -> IO ()
actionCh Int
ref Double
pos =
  Action -> IO ()
actionCh (EditorM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction (Int -> Double -> EditorM ()
setDividerPosE Int
ref Double
pos))

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

    -- see Note [PangoLayout width]
    (Bool
_, Int
charOffsetX, Int
extra) <- PangoLayout -> Double -> Double -> IO (Bool, Int, Int)
layoutXYToIndex PangoLayout
winLayout (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
1)) Double
y
    Point -> IO Point
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> IO Point) -> Point -> IO Point
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Point
forall a. Ord a => a -> a -> a
min Point
bufEnd (Point
tos Point -> Point -> Point
forall a. Num a => a -> a -> a
+ Int -> Point
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                         (Int
charOffsetX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Bool
im then Int
extra else Int
0))

selectArea :: UI -> WinInfo -> (Double, Double) -> IO ()
selectArea :: UI -> WinInfo -> (Double, Double) -> IO ()
selectArea UI
ui WinInfo
w (Double
x,Double
y) = do
  Point
p <- (Double, Double) -> WinInfo -> IO Point
pointToOffset (Double
x,Double
y) WinInfo
w
  let editorAction :: EditorM ()
editorAction = do
        YiString
txt <- BufferM YiString -> EditorM YiString
forall (m :: * -> *) a. MonadEditor m => BufferM a -> m a
withCurrentBuffer (BufferM YiString -> EditorM YiString)
-> BufferM YiString -> EditorM YiString
forall a b. (a -> b) -> a -> b
$ do
          Point -> BufferM ()
moveTo Point
p
          Bool -> BufferM ()
setVisibleSelection Bool
True
          Region -> BufferM YiString
readRegionB (Region -> BufferM YiString) -> BufferM Region -> BufferM YiString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BufferM Region
getSelectRegionB
        YiString -> EditorM ()
setRegE YiString
txt

  UI -> Action -> IO ()
uiActionCh UI
ui (EditorM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction EditorM ()
editorAction)
  -- drawWindowGetPointer (textview w) -- be ready for next message.

pasteSelectionClipboard :: UI -> WinInfo -> Point -> Clipboard -> IO ()
pasteSelectionClipboard :: UI -> WinInfo -> Point -> Clipboard -> IO ()
pasteSelectionClipboard UI
ui WinInfo
w Point
p Clipboard
cb = do
  Window
win <- IO Window -> IO Window
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO Window -> IO Window) -> IO Window -> IO Window
forall a b. (a -> b) -> a -> b
$ IORef Window -> IO Window
forall a. IORef a -> IO a
readIORef (WinInfo -> IORef Window
coreWin WinInfo
w)
  let cbHandler :: Maybe R.YiString -> IO ()
      cbHandler :: Maybe YiString -> IO ()
cbHandler Maybe YiString
Nothing    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      cbHandler (Just YiString
txt) = UI -> Action -> IO ()
uiActionCh UI
ui (Action -> IO ()) -> Action -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorM () -> Action
forall a. Show a => EditorM a -> Action
EditorA (EditorM () -> Action) -> EditorM () -> Action
forall a b. (a -> b) -> a -> b
$ do
        BufferRef
b <- (Editor -> BufferRef) -> EditorM BufferRef
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Editor -> BufferRef) -> EditorM BufferRef)
-> (Editor -> BufferRef) -> EditorM BufferRef
forall a b. (a -> b) -> a -> b
$ FBuffer -> BufferRef
bkey (FBuffer -> BufferRef)
-> (Editor -> FBuffer) -> Editor -> BufferRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win)
        Window -> BufferRef -> BufferM () -> EditorM ()
forall (m :: * -> *) a.
MonadEditor m =>
Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow Window
win BufferRef
b (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$ do
          BufferM Point
pointB BufferM Point -> (Point -> BufferM ()) -> BufferM ()
forall a b. BufferM a -> (a -> BufferM b) -> BufferM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Point -> BufferM ()
setSelectionMarkPointB
          Point -> BufferM ()
moveTo Point
p
          YiString -> BufferM ()
insertN YiString
txt
  Clipboard -> (Maybe Text -> IO ()) -> IO ()
forall self string.
(ClipboardClass self, GlibString string) =>
self -> (Maybe string -> IO ()) -> IO ()
clipboardRequestText Clipboard
cb (Maybe YiString -> IO ()
cbHandler (Maybe YiString -> IO ())
-> (Maybe Text -> Maybe YiString) -> Maybe Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> YiString) -> Maybe Text -> Maybe YiString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> YiString
R.fromText)

-- | Set selection clipboard contents to current selection
setSelectionClipboard :: UI -> WinInfo -> Clipboard -> IO ()
setSelectionClipboard :: UI -> WinInfo -> Clipboard -> IO ()
setSelectionClipboard UI
ui WinInfo
_w Clipboard
cb = do
  -- Why uiActionCh doesn't allow returning values?
  IORef Text
selection <- Text -> IO (IORef Text)
forall a. a -> IO (IORef a)
newIORef Text
forall a. Monoid a => a
mempty
  let yiAction :: YiM ()
yiAction = do
        Text
txt <- BufferM Text -> YiM Text
forall (m :: * -> *) a. MonadEditor m => BufferM a -> m a
withCurrentBuffer (BufferM Text -> YiM Text) -> BufferM Text -> YiM Text
forall a b. (a -> b) -> a -> b
$
               (YiString -> Text) -> BufferM YiString -> BufferM Text
forall a b. (a -> b) -> BufferM a -> BufferM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap YiString -> Text
R.toText (BufferM YiString -> BufferM Text)
-> (Region -> BufferM YiString) -> Region -> BufferM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Region -> BufferM YiString
readRegionB (Region -> BufferM Text) -> BufferM Region -> BufferM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BufferM Region
getSelectRegionB :: YiM T.Text
        IO () -> YiM ()
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO () -> YiM ()) -> IO () -> YiM ()
forall a b. (a -> b) -> a -> b
$ IORef Text -> Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Text
selection Text
txt
  UI -> Action -> IO ()
uiActionCh UI
ui (Action -> IO ()) -> Action -> IO ()
forall a b. (a -> b) -> a -> b
$ YiM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction YiM ()
yiAction
  Text
txt <- IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef IORef Text
selection

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
txt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Clipboard -> Text -> IO ()
forall self string.
(ClipboardClass self, GlibString string) =>
self -> string -> IO ()
clipboardSetText Clipboard
cb Text
txt