{-# 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 -> TabRef
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 t :: TabInfo
t = TabRef -> String
forall a. Show a => a -> String
show (TabInfo -> TabRef
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 w :: WinInfo
w = WindowRef -> String
forall a. Show a => a -> String
show (WinInfo -> WindowRef
coreWinKey WinInfo
w)

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

mkUI :: UI -> Common.UI Editor
mkUI :: UI -> UI Editor
mkUI ui :: 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 cfg :: UIConfig
cfg fontRef :: IORef FontDescription
fontRef tc :: IORef TabCache
tc status :: Statusbar
status font :: FontDescription
font = do
    IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
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
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
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 :: PangoLayout
winLayout :: WinLayoutInfo -> 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 :: Window -> FBuffer -> BufferM a -> a
askBuffer w :: Window
w b :: FBuffer
b f :: 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 (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 userHook :: Window -> IO ()
userHook cfg :: Config
cfg ch :: [Event] -> IO ()
ch outCh :: [Action] -> IO ()
outCh ed :: 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 _dom :: GErrorDomain
_dom _code :: TabRef
_code msg :: Text
msg) -> String -> IO (UI Editor)
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 userHook :: Window -> IO ()
userHook cfg :: Config
cfg ch :: [Event] -> IO ()
ch outCh :: [Action] -> IO ()
outCh ed :: Editor
ed = do
  Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn "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 "yi+lambda-fat-32.png"
  VBox
vb    <- Bool -> TabRef -> IO VBox
vBoxNew Bool
False 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_ (\k :: 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 TabRef
forall self. WindowClass self => Attr self TabRef
windowDefaultWidth  Attr Window TabRef -> TabRef -> AttrOp Window
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= 700
          , Attr Window TabRef
forall self. WindowClass self => Attr self TabRef
windowDefaultHeight Attr Window TabRef -> TabRef -> AttrOp Window
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= 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
:= ("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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [w :: 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
    _ -> () -> IO ()
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 (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 (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 ("Monospace 10" :: T.Text) IO FontDescription -> (FontDescription -> 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 -> TabRef -> TabRef -> IO GErrorDomain
timeoutAddFull (IO ()
yield IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) TabRef
priorityDefaultIdle 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 :: TabRef -> PointedList a -> PointedList a
move n :: TabRef
n pl :: PointedList a
pl = PointedList a -> Maybe (PointedList a) -> PointedList a
forall a. a -> Maybe a -> a
fromMaybe PointedList a
pl (TabRef -> PointedList a -> Maybe (PointedList a)
forall a. TabRef -> PointedList a -> Maybe (PointedList a)
PL.moveTo TabRef
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 -> (TabRef -> IO ()) -> IO ()
simpleNotebookOnSwitchPage (UI -> SimpleNotebook
uiNotebook UI
ui) ((TabRef -> IO ()) -> IO ()) -> (TabRef -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \n :: TabRef
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 (TabRef -> PointedList Tab -> PointedList Tab
forall a. TabRef -> PointedList a -> PointedList a
move TabRef
n) :: EditorM ())

  UI Editor -> IO (UI Editor)
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 "GTK main loop running" IO () -> IO () -> IO ()
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
ui e :: 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 TabRef TabInfo
cacheMap = PointedList (TabRef, TabInfo) -> Map TabRef TabInfo
forall (t :: * -> *) k a.
(Foldable t, Ord k) =>
t (k, a) -> Map k a
mapFromFoldable (PointedList (TabRef, TabInfo) -> Map TabRef TabInfo)
-> (TabCache -> PointedList (TabRef, TabInfo))
-> TabCache
-> Map TabRef TabInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TabInfo -> (TabRef, TabInfo))
-> TabCache -> PointedList (TabRef, TabInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\t :: TabInfo
t -> (TabInfo -> TabRef
coreTabKey TabInfo
t, TabInfo
t)) (TabCache -> Map TabRef TabInfo) -> TabCache -> Map TabRef 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
tab ->
         case TabRef -> Map TabRef TabInfo -> Maybe TabInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Tab -> TabRef
tkey Tab
tab) Map TabRef TabInfo
cacheMap of
           Just t :: TabInfo
t -> Editor -> UI -> Tab -> TabInfo -> IO ()
updateTabInfo Editor
e UI
ui Tab
tab TabInfo
t IO () -> IO TabInfo -> IO TabInfo
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TabInfo -> IO TabInfo
forall (m :: * -> *) a. Monad m => a -> m a
return TabInfo
t
           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' (\t :: 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 e :: Editor
e ui :: UI
ui tab :: Tab
tab tabInfo :: 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) (\w :: 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 wInfo :: WinInfo
wInfo -> Editor -> UI -> Window -> WinInfo -> IO ()
updateWindow Editor
e UI
ui Window
w WinInfo
wInfo IO () -> IO (WindowRef, WinInfo) -> IO (WindowRef, WinInfo)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (WindowRef, WinInfo) -> IO (WindowRef, WinInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> WindowRef
wkey Window
w, WinInfo
wInfo)
        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 w :: 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 (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 (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 e :: Editor
e _ui :: UI
_ui win :: Window
win wInfo :: 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
insertingA)

setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()
setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()
setWindowFocus e :: Editor
e ui :: UI
ui t :: TabInfo
t w :: 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 = TabRef -> FBuffer -> Text
shortIdentString ([String] -> TabRef
forall (t :: * -> *) a. Foldable t => t a -> TabRef
length ([String] -> TabRef) -> [String] -> TabRef
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 (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 (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
ui ref :: WindowRef
ref =
  let tabLoop :: [TabInfo] -> IO WinInfo
tabLoop []     = Text -> IO WinInfo
forall a. Text -> a
error "Yi.UI.Pango.getWinInfo: window not found"
      tabLoop (t :: TabInfo
t:ts :: [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 w :: WinInfo
w -> WinInfo -> IO WinInfo
forall (m :: * -> *) a. Monad m => a -> m a
return WinInfo
w
          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 (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 (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 e :: Editor
e actionCh :: 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)
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 e :: Editor
e ui :: UI
ui tab :: 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 (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 actionCh :: Action -> IO ()
actionCh tab :: 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 -> (TabRef -> DividerPosition -> IO ()) -> IO ()
layoutDisplayOnDividerMove LayoutDisplay
ld ((Action -> IO ()) -> TabRef -> DividerPosition -> IO ()
handleDividerMove Action -> IO ()
actionCh)
    MiniwindowDisplay
mwp <- IO MiniwindowDisplay
miniwindowDisplayNew
    VBox
tw <- Bool -> TabRef -> IO VBox
vBoxNew Bool
False 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 ""
    IORef Text
atRef <- Text -> IO (IORef Text)
forall a. a -> IO (IORef a)
newIORef ""
    TabInfo -> IO TabInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (TabRef
-> LayoutDisplay
-> MiniwindowDisplay
-> Widget
-> IORef WindowCache
-> IORef Text
-> IORef Text
-> TabInfo
TabInfo (Tab -> TabRef
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 e :: Editor
e ui :: UI
ui w :: 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
:= 0.01 ] -- so the text is left-justified.

    -- allow the modeline to be covered up, horizontally
    Label -> TabRef -> TabRef -> IO ()
forall self. WidgetClass self => self -> TabRef -> TabRef -> IO ()
widgetSetSizeRequest Label
ml 0 (-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 -> TabRef -> IO HBox
hBoxNew Bool
False 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 (m :: * -> *) a. Monad m => a -> m a
return (HBox -> Box
forall obj. GObjectClass obj => obj -> Box
castToBox HBox
hb)
     else do
      VBox
vb <- Bool -> TabRef -> IO VBox
vBoxNew Bool
False 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 (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
Mark -> Lens' FBuffer Point
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 0 0 0 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 :: WindowRef
-> IORef Window
-> IORef Point
-> IORef Bool
-> IORef Bool
-> IORef Bool
-> MVar WinLayoutInfo
-> FontMetrics
-> DrawingArea
-> Label
-> Widget
-> WinInfo
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> EventM EFocus Bool
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> EventM EFocus Bool
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 (m :: * -> *) a. Monad m => a -> m a
return WinInfo
win

refresh :: UI -> Editor -> IO ()
refresh :: UI -> Editor -> IO ()
refresh ui :: UI
ui e :: 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) ("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
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
$ \t :: 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
$ \w :: 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 e :: Editor
e _ui :: UI
_ui w :: 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
$ \wli :: 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 (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 :: UI -> WinInfo -> t -> IO Bool
render ui :: UI
ui w :: WinInfo
w _event :: 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 :: Point
tos :: WinLayoutInfo -> Point
tos,Point
bos :: Point
bos :: WinLayoutInfo -> Point
bos,Point
cur :: Point
cur :: WinLayoutInfo -> Point
cur,buffer :: WinLayoutInfo -> FBuffer
buffer=FBuffer
b,Maybe SearchExp
regex :: Maybe SearchExp
regex :: WinLayoutInfo -> 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
$ TabRef -> [Point] -> [Point]
forall a. TabRef -> [a] -> [a]
drop 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') | ((start' :: Point
start', s :: Attributes
s), end' :: Point
end') <- [((Point, Attributes), Point)]
picZip
                                    , Attributes
s Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
/= Attributes
emptyAttributes ]

        rel :: Point -> b
rel p :: 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
          (p1 :: Point
p1, Attributes fg :: Color
fg bg :: Color
bg _rv :: Bool
_rv bd :: Bool
bd itlc :: Bool
itlc udrl :: Bool
udrl, p2 :: Point
p2) <- [(Point, Attributes, Point)]
strokes
          let atr :: (t -> t -> t) -> t
atr x :: 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' p :: Bool
p x :: p
x y :: p
y = if Bool
p then p
x else p
y
          [PangoAttribute] -> [[PangoAttribute]]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (TabRef -> TabRef -> Color -> PangoAttribute)
-> Color -> PangoAttribute
forall t t t. (Num t, Num t) => (t -> t -> t) -> t
atr TabRef -> TabRef -> Color -> PangoAttribute
AttrForeground (Color -> PangoAttribute) -> Color -> PangoAttribute
forall a b. (a -> b) -> a -> b
$ Bool -> Color -> Color
mkCol Bool
True Color
fg
                 , (TabRef -> TabRef -> Color -> PangoAttribute)
-> Color -> PangoAttribute
forall t t t. (Num t, Num t) => (t -> t -> t) -> t
atr TabRef -> TabRef -> Color -> PangoAttribute
AttrBackground (Color -> PangoAttribute) -> Color -> PangoAttribute
forall a b. (a -> b) -> a -> b
$ Bool -> Color -> Color
mkCol Bool
False Color
bg
                 , (TabRef -> TabRef -> FontStyle -> PangoAttribute)
-> FontStyle -> PangoAttribute
forall t t t. (Num t, Num t) => (t -> t -> t) -> t
atr TabRef -> TabRef -> 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
                 , (TabRef -> TabRef -> Underline -> PangoAttribute)
-> Underline -> PangoAttribute
forall t t t. (Num t, Num t) => (t -> t -> t) -> t
atr TabRef -> TabRef -> 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
                 , (TabRef -> TabRef -> Weight -> PangoAttribute)
-> Weight -> PangoAttribute
forall t t t. (Num t, Num t) => (t -> t -> t) -> t
atr TabRef -> TabRef -> 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 -> TabRef -> TabRef -> PangoLayout -> IO ()
forall d.
DrawableClass d =>
d -> GC -> TabRef -> TabRef -> PangoLayout -> IO ()
drawLayout DrawWindow
drawWindow GC
gc 1 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
           AlwaysFat -> Bool
True
           NeverFat -> Bool
False
           FatWhenFocused -> Bool
focused
           FatWhenFocusedAndInserting -> Bool
focused Bool -> Bool -> Bool
&& Bool
im


    (PangoRectangle (DividerPosition -> DividerPosition
forall a. Enum a => a -> a
succ -> DividerPosition
curX) curY :: DividerPosition
curY curW :: DividerPosition
curW curH :: DividerPosition
curH, _) <-
      PangoLayout -> TabRef -> IO (PangoRectangle, PangoRectangle)
layoutGetCursorPos PangoLayout
layout (Point -> TabRef
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
$
      TabRef -> TabRef -> TabRef -> TabRef -> Rectangle
Rectangle (DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round DividerPosition
curX) (DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round DividerPosition
curY) (DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round DividerPosition
curW) (DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round DividerPosition
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 :: TabRef
Gtk.lineWidth = if Bool
wideCursor then 2 else 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 (DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round DividerPosition
curX, DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round DividerPosition
curY)
      (DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round (DividerPosition -> TabRef) -> DividerPosition -> TabRef
forall a b. (a -> b) -> a -> b
$ DividerPosition
curX DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
+ DividerPosition
curW, DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round (DividerPosition -> TabRef) -> DividerPosition -> TabRef
forall a b. (a -> b) -> a -> b
$ DividerPosition
curY DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
+ DividerPosition
curH)

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

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

doLayout :: UI -> Editor -> IO Editor
doLayout :: UI -> Editor -> IO Editor
doLayout ui :: UI
ui e :: 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 (TabRef, TabRef, Region)
dims <- PointedList (Map WindowRef (TabRef, TabRef, Region))
-> Map WindowRef (TabRef, TabRef, Region)
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (PointedList (Map WindowRef (TabRef, TabRef, Region))
 -> Map WindowRef (TabRef, TabRef, Region))
-> IO (PointedList (Map WindowRef (TabRef, TabRef, Region)))
-> IO (Map WindowRef (TabRef, TabRef, Region))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TabInfo -> IO (Map WindowRef (TabRef, TabRef, Region)))
-> TabCache
-> IO (PointedList (Map WindowRef (TabRef, TabRef, Region)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (UI
-> FontDescription
-> Editor
-> TabInfo
-> IO (Map WindowRef (TabRef, TabRef, 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 (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 w :: Window
w = case WindowRef
-> Map WindowRef (TabRef, TabRef, Region)
-> Maybe (TabRef, TabRef, Region)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Window -> WindowRef
wkey Window
w) Map WindowRef (TabRef, TabRef, Region)
dims of
                          Nothing -> Window
w
                          Just (wi :: TabRef
wi,h :: TabRef
h,rgn :: Region
rgn) -> Window
w { width :: TabRef
width = TabRef
wi, height :: TabRef
height = TabRef
h, winRegion :: Region
winRegion = Region
rgn }

    -- Don't leak references to old Windows
    let forceWin :: p -> Window -> p
forceWin x :: p
x w :: Window
w = Window -> TabRef
height Window
w TabRef -> p -> p
forall a b. a -> b -> b
`seq` Window -> Region
winRegion Window
w Region -> p -> p
forall a b. a -> b -> b
`seq` p
x
    Editor -> IO Editor
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 (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 p. p -> Window -> p
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 (TabRef, TabRef, Region))
getDimensionsInTab ui :: UI
ui f :: FontDescription
f e :: Editor
e tab :: 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 (TabRef, TabRef, Region))
-> IO (Map WindowRef (TabRef, TabRef, Region))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM WindowCache
wCache ((WinInfo -> IO (TabRef, TabRef, Region))
 -> IO (Map WindowRef (TabRef, TabRef, Region)))
-> (WinInfo -> IO (TabRef, TabRef, Region))
-> IO (Map WindowRef (TabRef, TabRef, Region))
forall a b. (a -> b) -> a -> b
$ \wi :: WinInfo
wi -> do
    (wid :: TabRef
wid, h :: TabRef
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 :: DividerPosition
lineHeight = FontMetrics -> DividerPosition
ascent FontMetrics
metrics DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
+ FontMetrics -> DividerPosition
descent FontMetrics
metrics
        charWidth :: DividerPosition
charWidth = DividerPosition -> DividerPosition -> DividerPosition
forall a. Ord a => a -> a -> a
max (FontMetrics -> DividerPosition
approximateCharWidth FontMetrics
metrics) (FontMetrics -> DividerPosition
approximateDigitWidth FontMetrics
metrics)
        width :: TabRef
width = DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round (DividerPosition -> TabRef) -> DividerPosition -> TabRef
forall a b. (a -> b) -> a -> b
$ TabRef -> DividerPosition
forall a b. (Integral a, Num b) => a -> b
fromIntegral TabRef
wid DividerPosition -> DividerPosition -> DividerPosition
forall a. Fractional a => a -> a -> a
/ DividerPosition
charWidth DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
- 1
        height :: TabRef
height = DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
round (DividerPosition -> TabRef) -> DividerPosition -> TabRef
forall a b. (a -> b) -> a -> b
$ TabRef -> DividerPosition
forall a b. (Integral a, Num b) => a -> b
fromIntegral TabRef
h DividerPosition -> DividerPosition -> DividerPosition
forall a. Fractional a => a -> a -> a
/ DividerPosition
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
    (TabRef, TabRef, Region) -> IO (TabRef, TabRef, Region)
forall (m :: * -> *) a. Monad m => a -> m a
return (TabRef
width, TabRef
height, Region
rgn)

shownRegion :: UI -> FontDescription -> WinInfo -> FBuffer -> IO Region
shownRegion :: UI -> FontDescription -> WinInfo -> FBuffer -> IO Region
shownRegion ui :: UI
ui f :: FontDescription
f w :: WinInfo
w b :: 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
$ \wli :: WinLayoutInfo
wli -> do
   (tos :: Point
tos, cur :: Point
cur, bos :: Point
bos, bufEnd :: 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 (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 lo :: a
lo hi :: a
hi x :: 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
ui font :: FontDescription
font w :: WinInfo
w b :: FBuffer
b layout :: PangoLayout
layout = do
  (width_' :: TabRef
width_', height' :: TabRef
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' :: TabRef
width' = TabRef -> TabRef -> TabRef
forall a. Ord a => a -> a -> a
max 0 (TabRef
width_' TabRef -> TabRef -> TabRef
forall a. Num a => a -> a -> a
- 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 TabRef -> DividerPosition
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TabRef -> DividerPosition)
-> Maybe TabRef -> Maybe DividerPosition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UIConfig -> Maybe TabRef
configFontSize (UI -> UIConfig
uiConfig UI
ui) of
    Nothing -> FontDescription -> IO FontDescription
forall (m :: * -> *) a. Monad m => a -> m a
return FontDescription
font
    Just defSize :: DividerPosition
defSize -> FontDescription -> IO (Maybe DividerPosition)
fontDescriptionGetSize FontDescription
font IO (Maybe DividerPosition)
-> (Maybe DividerPosition -> IO FontDescription)
-> IO FontDescription
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Nothing -> FontDescription -> DividerPosition -> IO ()
fontDescriptionSetSize FontDescription
font DividerPosition
defSize IO () -> IO FontDescription -> IO FontDescription
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FontDescription -> IO FontDescription
forall (m :: * -> *) a. Monad m => a -> m a
return FontDescription
font
      Just currentSize :: DividerPosition
currentSize -> let fsv :: TabRef
fsv     = Attributes -> TabRef
fontsizeVariation (Attributes -> TabRef) -> Attributes -> TabRef
forall a b. (a -> b) -> a -> b
$ FBuffer -> Attributes
attributes FBuffer
b
                              newSize :: DividerPosition
newSize = DividerPosition -> DividerPosition -> DividerPosition
forall a. Ord a => a -> a -> a
max 1 (TabRef -> DividerPosition
forall a b. (Integral a, Num b) => a -> b
fromIntegral TabRef
fsv DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
+ DividerPosition
defSize) in
        if DividerPosition
newSize DividerPosition -> DividerPosition -> Bool
forall a. Eq a => a -> a -> Bool
== DividerPosition
currentSize
          then FontDescription -> IO FontDescription
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 -> DividerPosition -> IO ()
fontDescriptionSetSize FontDescription
nf DividerPosition
newSize
          FontDescription -> IO FontDescription
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing)
                ((Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
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 [width'' :: DividerPosition
width'', height'' :: DividerPosition
height''] = (TabRef -> DividerPosition) -> [TabRef] -> [DividerPosition]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TabRef -> DividerPosition
forall a b. (Integral a, Num b) => a -> b
fromIntegral [TabRef
width', TabRef
height']
      metrics :: FontMetrics
metrics             = WinInfo -> FontMetrics
winMetrics WinInfo
w
      lineHeight :: DividerPosition
lineHeight          = FontMetrics -> DividerPosition
ascent FontMetrics
metrics DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
+ FontMetrics -> DividerPosition
descent FontMetrics
metrics
      charWidth :: DividerPosition
charWidth           = DividerPosition -> DividerPosition -> DividerPosition
forall a. Ord a => a -> a -> a
max (FontMetrics -> DividerPosition
approximateCharWidth FontMetrics
metrics)
                                (FontMetrics -> DividerPosition
approximateDigitWidth FontMetrics
metrics)
      winw :: TabRef
winw                = TabRef -> TabRef -> TabRef
forall a. Ord a => a -> a -> a
max 1 (TabRef -> TabRef) -> TabRef -> TabRef
forall a b. (a -> b) -> a -> b
$ DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
floor (DividerPosition
width'' DividerPosition -> DividerPosition -> DividerPosition
forall a. Fractional a => a -> a -> a
/ DividerPosition
charWidth)
      winh :: TabRef
winh                = TabRef -> TabRef -> TabRef
forall a. Ord a => a -> a -> a
max 1 (TabRef -> TabRef) -> TabRef -> TabRef
forall a b. (a -> b) -> a -> b
$ DividerPosition -> TabRef
forall a b. (RealFrac a, Integral b) => a -> b
floor (DividerPosition
height'' DividerPosition -> DividerPosition -> DividerPosition
forall a. Fractional a => a -> a -> a
/ DividerPosition
lineHeight)
      maxChars :: TabRef
maxChars            = TabRef
winw TabRef -> TabRef -> TabRef
forall a. Num a => a -> a -> a
* TabRef
winh
      conf :: UIConfig
conf                = UI -> UIConfig
uiConfig UI
ui

      (tos :: Point
tos, size :: Point
size, point :: Point
point, text :: 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
Mark -> Lens' FBuffer Point
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 -> TabRef -> YiString -> YiString
takeContent UIConfig
conf TabRef
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
$ TabRef -> YiString -> (YiString, YiString)
R.splitAtLine TabRef
winh YiString
rope

        -- allow BOS offset to be just after the last line
        let addNL :: YiString -> YiString
addNL = if YiString -> TabRef
R.countNewLines YiString
content TabRef -> TabRef -> Bool
forall a. Eq a => a -> a -> Bool
== TabRef
winh
                        then YiString -> YiString
forall a. a -> a
id
                        else (YiString -> Char -> YiString
`R.snoc` '\n')
        (Point, Point, Point, Text) -> BufferM (Point, Point, Point, Text)
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 -> DividerPosition -> IO ()
wrapToWidth PangoLayout
layout LayoutWrapMode
WrapAnywhere DividerPosition
width''
    else do
    (Rectangle px :: TabRef
px _py :: TabRef
_py pwidth :: TabRef
pwidth _pheight :: TabRef
_pheight, _) <- PangoLayout -> IO (Rectangle, Rectangle)
layoutGetPixelExtents PangoLayout
layout
    DrawingArea -> TabRef -> TabRef -> IO ()
forall self. WidgetClass self => self -> TabRef -> TabRef -> IO ()
widgetSetSizeRequest (WinInfo -> DrawingArea
textview WinInfo
w) (TabRef
pxTabRef -> TabRef -> TabRef
forall a. Num a => a -> a -> a
+TabRef
pwidth) (-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)

  (_, bosOffset :: TabRef
bosOffset, _) <- PangoLayout
-> DividerPosition -> DividerPosition -> IO (Bool, TabRef, TabRef)
layoutXYToIndex PangoLayout
layout DividerPosition
width''
                       (TabRef -> DividerPosition
forall a b. (Integral a, Num b) => a -> b
fromIntegral TabRef
winh DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
* DividerPosition
lineHeight DividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
- 1)
  (Point, Point, Point, Point) -> IO (Point, Point, Point, Point)
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
+ TabRef -> Point
forall a b. (Integral a, Num b) => a -> b
fromIntegral TabRef
bosOffset Point -> Point -> Point
forall a. Num a => a -> a -> a
+ 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 -> TabRef -> YiString -> YiString
takeContent cf :: UIConfig
cf cl :: TabRef
cl t :: YiString
t = if UIConfig -> Bool
configLineWrap UIConfig
cf
                        then TabRef -> YiString -> YiString
R.take TabRef
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 -> DividerPosition -> IO ()
wrapToWidth l :: PangoLayout
l wm :: LayoutWrapMode
wm w :: DividerPosition
w = do
  PangoLayout -> IO LayoutWrapMode
layoutGetWrap PangoLayout
l IO LayoutWrapMode -> (LayoutWrapMode -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \wr :: LayoutWrapMode
wr -> case (LayoutWrapMode
wr, LayoutWrapMode
wm) of
    -- No Eq instance…
    (WrapWholeWords, WrapWholeWords) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (WrapAnywhere, WrapAnywhere) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (WrapPartialWords, WrapPartialWords) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    _ -> PangoLayout -> LayoutWrapMode -> IO ()
layoutSetWrap PangoLayout
l LayoutWrapMode
wm

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

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

mkCol :: Bool -- ^ is foreground?
      -> Yi.Style.Color -> Gtk.Color
mkCol :: Bool -> Color -> Color
mkCol True  Default = Word16 -> Word16 -> Word16 -> Color
Color 0 0 0
mkCol False 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 _ (RGB x :: Word8
x y :: Word8
y z :: 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
* 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
* 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
* 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 ch :: [Event] -> IO ()
ch im :: 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 (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 c :: 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
        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
    (True, _   ) -> () -> ReaderT (Ptr EKey) IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (_, 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
$ "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
    (_, Just k :: 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 (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 :: object -> Signal object callback -> callback -> IO ()
on widget :: object
widget signal :: Signal object callback
signal handler :: 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
ui ref :: WindowRef
ref = do
  (x :: DividerPosition
x, y :: DividerPosition
y) <- EventM EButton (DividerPosition, DividerPosition)
forall t.
HasCoordinates t =>
EventM t (DividerPosition, DividerPosition)
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 <- (DividerPosition, DividerPosition) -> WinInfo -> IO Point
pointToOffset (DividerPosition
x, DividerPosition
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 tu :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextUnit -> BufferM Region
regionOfB TextUnit
tu BufferM Region -> (Region -> BufferM ()) -> BufferM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Region -> BufferM ()
setSelectRegionB

    case (Click
click, MouseButton
button) of
      (SingleClick, 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 -> Lens' FBuffer Point
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
      (DoubleClick, LeftButton) -> TextUnit -> IO ()
selectRegion TextUnit
unitWord
      (TripleClick, LeftButton) -> TextUnit -> IO ()
selectRegion TextUnit
Line
      _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool -> IO Bool
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
ui w :: WinInfo
w = do
  (x :: DividerPosition
x, y :: DividerPosition
y)   <- EventM EButton (DividerPosition, DividerPosition)
forall t.
HasCoordinates t =>
EventM t (DividerPosition, DividerPosition)
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 <- (DividerPosition, DividerPosition) -> WinInfo -> IO Point
pointToOffset (DividerPosition
x, DividerPosition
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
         MiddleButton -> UI -> WinInfo -> Point -> Clipboard -> IO ()
pasteSelectionClipboard UI
ui WinInfo
w Point
point Clipboard
cb
         LeftButton   -> UI -> WinInfo -> Clipboard -> IO ()
setSelectionClipboard   UI
ui WinInfo
w Clipboard
cb IO () -> IO () -> IO ()
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
         _            -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool -> EventM EButton Bool
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
ui w :: WinInfo
w = do
  ScrollDirection
scrollDirection <- EventM EScroll ScrollDirection
eventScrollDirection
  (DividerPosition, DividerPosition)
xy <- EventM EScroll (DividerPosition, DividerPosition)
forall t.
HasCoordinates t =>
EventM t (DividerPosition, DividerPosition)
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
$ TabRef -> BufferM ()
scrollB (TabRef -> BufferM ()) -> TabRef -> BufferM ()
forall a b. (a -> b) -> a -> b
$ case ScrollDirection
scrollDirection of
            ScrollUp   -> TabRef -> TabRef
forall a. Num a => a -> a
negate TabRef
configAmount
            ScrollDown -> TabRef
configAmount
            _          -> 0 -- Left/right scrolling not supported
        configAmount :: TabRef
configAmount = UIConfig -> TabRef
configScrollWheelAmount (UIConfig -> TabRef) -> UIConfig -> TabRef
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 -> (DividerPosition, DividerPosition) -> IO ()
selectArea UI
ui WinInfo
w (DividerPosition, DividerPosition)
xy
  Bool -> EventM EScroll Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

handleConfigure :: UI -> EventM EConfigure Bool
handleConfigure :: UI -> EventM EConfigure Bool
handleConfigure ui :: 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 (m :: * -> *) a. Monad m => a -> m a
return () :: EditorM()))
  Bool -> EventM EConfigure Bool
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
ui w :: WinInfo
w = EventM EMotion (DividerPosition, DividerPosition)
forall t.
HasCoordinates t =>
EventM t (DividerPosition, DividerPosition)
eventCoordinates EventM EMotion (DividerPosition, DividerPosition)
-> ((DividerPosition, DividerPosition)
    -> ReaderT (Ptr EMotion) IO ())
-> ReaderT (Ptr EMotion) IO ()
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 ())
-> ((DividerPosition, DividerPosition) -> IO ())
-> (DividerPosition, DividerPosition)
-> ReaderT (Ptr EMotion) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UI -> WinInfo -> (DividerPosition, DividerPosition) -> IO ()
selectArea UI
ui WinInfo
w) ReaderT (Ptr EMotion) IO ()
-> EventM EMotion Bool -> EventM EMotion Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                  Bool -> EventM EMotion Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

-- | Convert point coordinates to offset in Yi window
pointToOffset :: (Double, Double) -> WinInfo -> IO Point
pointToOffset :: (DividerPosition, DividerPosition) -> WinInfo -> IO Point
pointToOffset (x :: DividerPosition
x,y :: DividerPosition
y) w :: 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 :: PangoLayout
winLayout :: WinLayoutInfo -> PangoLayout
winLayout,Point
tos :: Point
tos :: WinLayoutInfo -> Point
tos,Point
bufEnd :: Point
bufEnd :: WinLayoutInfo -> 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]
    (_, charOffsetX :: TabRef
charOffsetX, extra :: TabRef
extra) <- PangoLayout
-> DividerPosition -> DividerPosition -> IO (Bool, TabRef, TabRef)
layoutXYToIndex PangoLayout
winLayout (DividerPosition -> DividerPosition -> DividerPosition
forall a. Ord a => a -> a -> a
max 0 (DividerPosition
xDividerPosition -> DividerPosition -> DividerPosition
forall a. Num a => a -> a -> a
-1)) DividerPosition
y
    Point -> IO Point
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
+ TabRef -> Point
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                         (TabRef
charOffsetX TabRef -> TabRef -> TabRef
forall a. Num a => a -> a -> a
+ if Bool
im then TabRef
extra else 0))

selectArea :: UI -> WinInfo -> (Double, Double) -> IO ()
selectArea :: UI -> WinInfo -> (DividerPosition, DividerPosition) -> IO ()
selectArea ui :: UI
ui w :: WinInfo
w (x :: DividerPosition
x,y :: DividerPosition
y) = do
  Point
p <- (DividerPosition, DividerPosition) -> WinInfo -> IO Point
pointToOffset (DividerPosition
x,DividerPosition
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
ui w :: WinInfo
w p :: Point
p cb :: 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 Nothing    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      cbHandler (Just txt :: 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 (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 (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
ui _w :: WinInfo
_w cb :: 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 (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