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

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

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

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

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

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

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

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

--type ControlM = YiM
newtype ControlM a = ControlM { forall a. ControlM a -> ReaderT Control IO a
runControl'' :: ReaderT Control IO a }
    deriving (Applicative ControlM
Applicative ControlM
-> (forall a b. ControlM a -> (a -> ControlM b) -> ControlM b)
-> (forall a b. ControlM a -> ControlM b -> ControlM b)
-> (forall a. a -> ControlM a)
-> Monad ControlM
forall a. a -> ControlM a
forall a b. ControlM a -> ControlM b -> ControlM b
forall a b. ControlM a -> (a -> ControlM b) -> ControlM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. ControlM a -> (a -> ControlM b) -> ControlM b
>>= :: forall a b. ControlM a -> (a -> ControlM b) -> ControlM b
$c>> :: forall a b. ControlM a -> ControlM b -> ControlM b
>> :: forall a b. ControlM a -> ControlM b -> ControlM b
$creturn :: forall a. a -> ControlM a
return :: forall a. a -> ControlM a
Monad, MonadBase IO, MonadReader Control, Typeable,
              (forall a b. (a -> b) -> ControlM a -> ControlM b)
-> (forall a b. a -> ControlM b -> ControlM a) -> Functor ControlM
forall a b. a -> ControlM b -> ControlM a
forall a b. (a -> b) -> ControlM a -> ControlM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ControlM a -> ControlM b
fmap :: forall a b. (a -> b) -> ControlM a -> ControlM b
$c<$ :: forall a b. a -> ControlM b -> ControlM a
<$ :: forall a b. a -> ControlM b -> ControlM a
Functor, Functor ControlM
Functor ControlM
-> (forall a. a -> ControlM a)
-> (forall a b. ControlM (a -> b) -> ControlM a -> ControlM b)
-> (forall a b c.
    (a -> b -> c) -> ControlM a -> ControlM b -> ControlM c)
-> (forall a b. ControlM a -> ControlM b -> ControlM b)
-> (forall a b. ControlM a -> ControlM b -> ControlM a)
-> Applicative ControlM
forall a. a -> ControlM a
forall a b. ControlM a -> ControlM b -> ControlM a
forall a b. ControlM a -> ControlM b -> ControlM b
forall a b. ControlM (a -> b) -> ControlM a -> ControlM b
forall a b c.
(a -> b -> c) -> ControlM a -> ControlM b -> ControlM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> ControlM a
pure :: forall a. a -> ControlM a
$c<*> :: forall a b. ControlM (a -> b) -> ControlM a -> ControlM b
<*> :: forall a b. ControlM (a -> b) -> ControlM a -> ControlM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> ControlM a -> ControlM b -> ControlM c
liftA2 :: forall a b c.
(a -> b -> c) -> ControlM a -> ControlM b -> ControlM c
$c*> :: forall a b. ControlM a -> ControlM b -> ControlM b
*> :: forall a b. ControlM a -> ControlM b -> ControlM b
$c<* :: forall a b. ControlM a -> ControlM b -> ControlM a
<* :: forall a b. ControlM a -> ControlM b -> ControlM a
Applicative)

-- Helper functions to avoid issues with mismatching monad libraries
controlIO :: IO a -> ControlM a
controlIO :: forall α. IO α -> ControlM α
controlIO = IO a -> ControlM a
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

getControl :: ControlM Control
getControl :: ControlM Control
getControl = ControlM Control
forall r (m :: * -> *). MonadReader r m => m r
ask

liftYi :: YiM a -> ControlM a
liftYi :: forall a. YiM a -> ControlM a
liftYi YiM a
m = do
    Yi
yi <- (Control -> Yi) -> ControlM Yi
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Control -> Yi
controlYi
    IO a -> ControlM a
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> ControlM a) -> IO a -> ControlM a
forall a b. (a -> b) -> a -> b
$ ReaderT Yi IO a -> Yi -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (YiM a -> ReaderT Yi IO a
forall a. YiM a -> ReaderT Yi IO a
runYiM YiM a
m) Yi
yi

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

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

startControl :: Config -> ControlM () -> IO ()
startControl :: Config -> ControlM () -> IO ()
startControl Config
config ControlM ()
main = Config -> Maybe Editor -> IO ()
startEditor (Config
config { startFrontEnd :: UIBoot
startFrontEnd = ControlM () -> UIBoot
start ControlM ()
main } ) Maybe Editor
forall a. Maybe a
Nothing

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

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

runControl :: ControlM a -> Control -> IO a
runControl :: forall a. ControlM a -> Control -> IO a
runControl ControlM a
f = ReaderT Control IO a -> Control -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ControlM a -> ReaderT Control IO a
forall a. ControlM a -> ReaderT Control IO a
runControl'' ControlM a
f)

-- runControlEditor f yiMVar = yiMVar

runAction :: Action -> ControlM ()
runAction :: Action -> ControlM ()
runAction Action
action = do
    IsRefreshNeeded -> [Action] -> IO ()
out <- YiM (IsRefreshNeeded -> [Action] -> IO ())
-> ControlM (IsRefreshNeeded -> [Action] -> IO ())
forall a. YiM a -> ControlM a
liftYi (YiM (IsRefreshNeeded -> [Action] -> IO ())
 -> ControlM (IsRefreshNeeded -> [Action] -> IO ()))
-> YiM (IsRefreshNeeded -> [Action] -> IO ())
-> ControlM (IsRefreshNeeded -> [Action] -> IO ())
forall a b. (a -> b) -> a -> b
$ (Yi -> IsRefreshNeeded -> [Action] -> IO ())
-> YiM (IsRefreshNeeded -> [Action] -> IO ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Yi -> IsRefreshNeeded -> [Action] -> IO ()
yiOutput
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ IsRefreshNeeded -> [Action] -> IO ()
out IsRefreshNeeded
MustRefresh [Action
action]

-- | Test 2
mkUI :: IO () -> MVar Control -> Common.UI Editor
mkUI :: IO () -> MVar Control -> UI Editor
mkUI IO ()
main MVar Control
yiMVar = UI Any
forall e. UI e
Common.dummyUI
    { main :: IO ()
Common.main          = IO ()
main
    , end :: Maybe ExitCode -> IO ()
Common.end           = \Maybe ExitCode
_ -> IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ControlM () -> MVar Control -> IO (Maybe ())
forall a. ControlM a -> MVar Control -> IO (Maybe a)
runControl' ControlM ()
end MVar Control
yiMVar
    , suspend :: IO ()
Common.suspend       = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ControlM () -> MVar Control -> IO (Maybe ())
forall a. ControlM a -> MVar Control -> IO (Maybe a)
runControl' ControlM ()
suspend MVar Control
yiMVar
    , refresh :: Editor -> IO ()
Common.refresh       = \Editor
e -> IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ControlM () -> MVar Control -> IO (Maybe ())
forall a. ControlM a -> MVar Control -> IO (Maybe a)
runControl' (Editor -> ControlM ()
refresh Editor
e) MVar Control
yiMVar
    , layout :: Editor -> IO Editor
Common.layout        = \Editor
e -> (Maybe Editor -> Editor) -> IO (Maybe Editor) -> IO Editor
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Editor -> Maybe Editor -> Editor
forall a. a -> Maybe a -> a
fromMaybe Editor
e) (IO (Maybe Editor) -> IO Editor) -> IO (Maybe Editor) -> IO Editor
forall a b. (a -> b) -> a -> b
$
                                   ControlM Editor -> MVar Control -> IO (Maybe Editor)
forall a. ControlM a -> MVar Control -> IO (Maybe a)
runControl' (Editor -> ControlM Editor
doLayout Editor
e) MVar Control
yiMVar
    , reloadProject :: String -> IO ()
Common.reloadProject = \String
f -> IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ControlM () -> MVar Control -> IO (Maybe ())
forall a. ControlM a -> MVar Control -> IO (Maybe a)
runControl' (String -> ControlM ()
reloadProject String
f) MVar Control
yiMVar
    }

start :: ControlM () -> UIBoot
start :: ControlM () -> UIBoot
start ControlM ()
main Config
cfg [Event] -> IO ()
ch [Action] -> IO ()
outCh Editor
ed =
  IO (UI Editor) -> (GError -> IO (UI Editor)) -> IO (UI Editor)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (ControlM () -> UIBoot
startNoMsg ControlM ()
main Config
cfg [Event] -> IO ()
ch [Action] -> IO ()
outCh Editor
ed) (\(GError InfoId
_dom Int
_code Text
msg) ->
                                            String -> IO (UI Editor)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (UI Editor)) -> String -> IO (UI Editor)
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
msg)

makeControl :: MVar Control -> YiM ()
makeControl :: MVar Control -> YiM ()
makeControl MVar Control
controlMVar = do
    Yi
controlYi <- YiM Yi
forall r (m :: * -> *). MonadReader r m => m r
ask
    IORef [TabInfo]
tabCache  <- IO (IORef [TabInfo]) -> YiM (IORef [TabInfo])
forall α. IO α -> YiM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (IORef [TabInfo]) -> YiM (IORef [TabInfo]))
-> IO (IORef [TabInfo]) -> YiM (IORef [TabInfo])
forall a b. (a -> b) -> a -> b
$ [TabInfo] -> IO (IORef [TabInfo])
forall a. a -> IO (IORef a)
newIORef []
    IORef (Map WindowRef View)
views  <- IO (IORef (Map WindowRef View)) -> YiM (IORef (Map WindowRef View))
forall α. IO α -> YiM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (IORef (Map WindowRef View))
 -> YiM (IORef (Map WindowRef View)))
-> IO (IORef (Map WindowRef View))
-> YiM (IORef (Map WindowRef View))
forall a b. (a -> b) -> a -> b
$ Map WindowRef View -> IO (IORef (Map WindowRef View))
forall a. a -> IO (IORef a)
newIORef Map WindowRef View
forall k a. Map k a
Map.empty
    IO () -> YiM ()
forall α. IO α -> YiM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> YiM ()) -> IO () -> YiM ()
forall a b. (a -> b) -> a -> b
$ MVar Control -> Control -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Control
controlMVar Control{IORef [TabInfo]
IORef (Map WindowRef View)
Yi
controlYi :: Yi
tabCache :: IORef [TabInfo]
views :: IORef (Map WindowRef View)
controlYi :: Yi
tabCache :: IORef [TabInfo]
views :: IORef (Map WindowRef View)
..}

startNoMsg :: ControlM () -> UIBoot
startNoMsg :: ControlM () -> UIBoot
startNoMsg ControlM ()
main Config
config [Event] -> IO ()
input [Action] -> IO ()
output Editor
ed = do
    MVar Control
control <- IO (MVar Control)
forall a. IO (MVar a)
newEmptyMVar
    let wrappedMain :: IO ()
wrappedMain = do
          [Action] -> IO ()
output [YiM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction (YiM () -> Action) -> YiM () -> Action
forall a b. (a -> b) -> a -> b
$ MVar Control -> YiM ()
makeControl MVar Control
control]
          IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ControlM () -> MVar Control -> IO (Maybe ())
forall a. ControlM a -> MVar Control -> IO (Maybe a)
runControl' ControlM ()
main MVar Control
control)
    UI Editor -> IO (UI Editor)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> MVar Control -> UI Editor
mkUI IO ()
wrappedMain MVar Control
control)

end :: ControlM ()
end :: ControlM ()
end = do
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Yi Control End"
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO ()
mainQuit

suspend :: ControlM ()
suspend :: ControlM ()
suspend = do
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Yi Control Suspend"
    () -> ControlM ()
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

    Editor -> ControlM ()
updateCache Editor
e -- The cursor may have changed since doLayout
    IORef (Map WindowRef View)
viewsRef <- (Control -> IORef (Map WindowRef View))
-> ControlM (IORef (Map WindowRef View))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Control -> IORef (Map WindowRef View)
views
    Map WindowRef View
vs <- IO (Map WindowRef View) -> ControlM (Map WindowRef View)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Map WindowRef View) -> ControlM (Map WindowRef View))
-> IO (Map WindowRef View) -> ControlM (Map WindowRef View)
forall a b. (a -> b) -> a -> b
$ IORef (Map WindowRef View) -> IO (Map WindowRef View)
forall a. IORef a -> IO a
readIORef IORef (Map WindowRef View)
viewsRef
    [View] -> (View -> ControlM ()) -> ControlM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map WindowRef View -> [View]
forall k a. Map k a -> [a]
Map.elems Map WindowRef View
vs) ((View -> ControlM ()) -> ControlM ())
-> (View -> ControlM ()) -> ControlM ()
forall a b. (a -> b) -> a -> b
$ \View
v -> do
        let b :: FBuffer
b = BufferRef -> Editor -> FBuffer
findBufferWith (View -> BufferRef
viewFBufRef View
v) Editor
e
        -- when (not $ null $ b ^. pendingUpdatesA) $
        do
            -- sig <- readIORef (renderer w)
            -- signalDisconnect sig
            -- writeRef (renderer w)
            -- =<< (textview w `onExpose` render e ui b (wkey (coreWin w)))
            IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw (View -> DrawingArea
drawArea View
v)

doLayout :: Editor -> ControlM Editor
doLayout :: Editor -> ControlM Editor
doLayout Editor
e = do
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Yi Control Do Layout"
    Editor -> ControlM ()
updateCache Editor
e
    IORef [TabInfo]
cacheRef <- (Control -> IORef [TabInfo]) -> ControlM (IORef [TabInfo])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Control -> IORef [TabInfo]
tabCache
    [TabInfo]
tabs <- IO [TabInfo] -> ControlM [TabInfo]
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO [TabInfo] -> ControlM [TabInfo])
-> IO [TabInfo] -> ControlM [TabInfo]
forall a b. (a -> b) -> a -> b
$ IORef [TabInfo] -> IO [TabInfo]
forall a. IORef a -> IO a
readIORef IORef [TabInfo]
cacheRef
    [(WindowRef, Int, Int, Region)]
dims <- [[(WindowRef, Int, Int, Region)]]
-> [(WindowRef, Int, Int, Region)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(WindowRef, Int, Int, Region)]]
 -> [(WindowRef, Int, Int, Region)])
-> ControlM [[(WindowRef, Int, Int, Region)]]
-> ControlM [(WindowRef, Int, Int, Region)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TabInfo -> ControlM [(WindowRef, Int, Int, Region)])
-> [TabInfo] -> ControlM [[(WindowRef, Int, Int, Region)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Editor -> TabInfo -> ControlM [(WindowRef, Int, Int, Region)]
getDimensionsInTab Editor
e) [TabInfo]
tabs
    let e' :: Editor
e' = ((PointedList Tab -> Identity (PointedList Tab))
-> Editor -> Identity Editor
Lens' Editor (PointedList Tab)
tabsA ((PointedList Tab -> Identity (PointedList Tab))
 -> Editor -> Identity Editor)
-> (PointedList Tab -> PointedList Tab) -> Editor -> Editor
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Tab -> Tab) -> PointedList Tab -> PointedList Tab
forall a b. (a -> b) -> PointedList a -> PointedList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Window -> Window) -> Tab -> Tab
mapWindows Window -> Window
updateWin)) Editor
e
        updateWin :: Window -> Window
updateWin Window
w = case ((WindowRef, Int, Int, Region) -> Bool)
-> [(WindowRef, Int, Int, Region)]
-> Maybe (WindowRef, Int, Int, Region)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(WindowRef
ref,Int
_,Int
_,Region
_) -> (Window -> WindowRef
wkey Window
w WindowRef -> WindowRef -> Bool
forall a. Eq a => a -> a -> Bool
== WindowRef
ref)) [(WindowRef, Int, Int, Region)]
dims of
                          Maybe (WindowRef, Int, Int, Region)
Nothing -> Window
w
                          Just (WindowRef
_, Int
wi, Int
h,Region
rgn) -> Window
w { width :: Int
width = Int
wi
                                                   , height :: Int
height = Int
h
                                                   , winRegion :: Region
winRegion = Region
rgn }
    -- Don't leak references to old Windows
    let forceWin :: b -> Window -> b
forceWin b
x Window
w = Window -> Int
height Window
w Int -> b -> b
forall a b. a -> b -> b
`seq` Window -> Region
winRegion Window
w Region -> b -> b
forall a b. a -> b -> b
`seq` b
x
    Editor -> ControlM Editor
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Editor -> ControlM Editor) -> Editor -> ControlM Editor
forall a b. (a -> b) -> a -> b
$ ((Editor -> Tab -> Editor) -> Editor -> PointedList Tab -> Editor
forall b a. (b -> a -> b) -> b -> PointedList a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Editor -> Tab -> Editor) -> Editor -> PointedList Tab -> Editor)
-> ((Editor -> Window -> Editor) -> Editor -> Tab -> Editor)
-> (Editor -> Window -> Editor)
-> Editor
-> PointedList Tab
-> Editor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Editor -> Window -> Editor) -> Editor -> Tab -> Editor
forall a. (a -> Window -> a) -> a -> Tab -> a
tabFoldl) Editor -> Window -> Editor
forall {b}. b -> Window -> b
forceWin Editor
e' (Editor
e' Editor
-> Getting (PointedList Tab) Editor (PointedList Tab)
-> PointedList Tab
forall s a. s -> Getting a s a -> a
^. Getting (PointedList Tab) Editor (PointedList Tab)
Lens' Editor (PointedList Tab)
tabsA)

-- | Width, Height
getDimensionsInTab :: Editor -> TabInfo -> ControlM [(WindowRef,Int,Int,Region)]
getDimensionsInTab :: Editor -> TabInfo -> ControlM [(WindowRef, Int, Int, Region)]
getDimensionsInTab Editor
e TabInfo
tab = do
  IORef (Map WindowRef View)
viewsRef <- (Control -> IORef (Map WindowRef View))
-> ControlM (IORef (Map WindowRef View))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Control -> IORef (Map WindowRef View)
views
  Map WindowRef View
vs <- IO (Map WindowRef View) -> ControlM (Map WindowRef View)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Map WindowRef View) -> ControlM (Map WindowRef View))
-> IO (Map WindowRef View) -> ControlM (Map WindowRef View)
forall a b. (a -> b) -> a -> b
$ IORef (Map WindowRef View) -> IO (Map WindowRef View)
forall a. IORef a -> IO a
readIORef IORef (Map WindowRef View)
viewsRef
  ([(WindowRef, Int, Int, Region)]
 -> Window -> ControlM [(WindowRef, Int, Int, Region)])
-> [(WindowRef, Int, Int, Region)]
-> PointedList Window
-> ControlM [(WindowRef, Int, Int, Region)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\[(WindowRef, Int, Int, Region)]
a Window
w ->
        case WindowRef -> Map WindowRef View -> Maybe View
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Window -> WindowRef
wkey Window
w) Map WindowRef View
vs of
            Just View
v -> do
                (Int
wi, Int
h) <- IO (Int, Int) -> ControlM (Int, Int)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Int, Int) -> ControlM (Int, Int))
-> IO (Int, Int) -> ControlM (Int, Int)
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO (Int, Int)
forall widget. WidgetClass widget => widget -> IO (Int, Int)
widgetGetSize (DrawingArea -> IO (Int, Int)) -> DrawingArea -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ View -> DrawingArea
drawArea View
v
                let lineHeight :: Double
lineHeight = FontMetrics -> Double
ascent (View -> FontMetrics
metrics View
v) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ FontMetrics -> Double
descent (View -> FontMetrics
metrics View
v)
                    charWidth :: Double
charWidth = FontMetrics -> Double
Gtk.approximateCharWidth (FontMetrics -> Double) -> FontMetrics -> Double
forall a b. (a -> b) -> a -> b
$ View -> FontMetrics
metrics View
v
                    b0 :: FBuffer
b0 = BufferRef -> Editor -> FBuffer
findBufferWith (View -> BufferRef
viewFBufRef View
v) Editor
e
                Region
rgn <- Editor -> View -> FBuffer -> ControlM Region
shownRegion Editor
e View
v FBuffer
b0
                let ret :: (WindowRef, Int, Int, Region)
ret= (View -> WindowRef
windowRef View
v, Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
charWidth, 
                          Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lineHeight, Region
rgn)
                [(WindowRef, Int, Int, Region)]
-> ControlM [(WindowRef, Int, Int, Region)]
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(WindowRef, Int, Int, Region)]
 -> ControlM [(WindowRef, Int, Int, Region)])
-> [(WindowRef, Int, Int, Region)]
-> ControlM [(WindowRef, Int, Int, Region)]
forall a b. (a -> b) -> a -> b
$ [(WindowRef, Int, Int, Region)]
a [(WindowRef, Int, Int, Region)]
-> [(WindowRef, Int, Int, Region)]
-> [(WindowRef, Int, Int, Region)]
forall a. Semigroup a => a -> a -> a
<> [(WindowRef, Int, Int, Region)
ret]
            Maybe View
Nothing -> [(WindowRef, Int, Int, Region)]
-> ControlM [(WindowRef, Int, Int, Region)]
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(WindowRef, Int, Int, Region)]
a)
      [] (TabInfo -> Tab
coreTab TabInfo
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)

shownRegion :: Editor -> View -> FBuffer -> ControlM Region
shownRegion :: Editor -> View -> FBuffer -> ControlM Region
shownRegion Editor
e View
v FBuffer
b = do
   (Point
tos, Point
_, Point
bos) <- Editor
-> View -> FBuffer -> PangoLayout -> ControlM (Point, Point, Point)
updatePango Editor
e View
v FBuffer
b (View -> PangoLayout
layout View
v)
   Region -> ControlM Region
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Region -> ControlM Region) -> Region -> ControlM Region
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Region
mkRegion Point
tos Point
bos

updatePango :: Editor -> View -> FBuffer -> PangoLayout
            -> ControlM (Point, Point, Point)
updatePango :: Editor
-> View -> FBuffer -> PangoLayout -> ControlM (Point, Point, Point)
updatePango Editor
e View
v FBuffer
b PangoLayout
layout = do
  (Int
width', Int
height') <- IO (Int, Int) -> ControlM (Int, Int)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Int, Int) -> ControlM (Int, Int))
-> IO (Int, Int) -> ControlM (Int, Int)
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO (Int, Int)
forall widget. WidgetClass widget => widget -> IO (Int, Int)
widgetGetSize (DrawingArea -> IO (Int, Int)) -> DrawingArea -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ View -> DrawingArea
drawArea View
v

  Maybe FontDescription
font <- IO (Maybe FontDescription) -> ControlM (Maybe FontDescription)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Maybe FontDescription) -> ControlM (Maybe FontDescription))
-> IO (Maybe FontDescription) -> ControlM (Maybe FontDescription)
forall a b. (a -> b) -> a -> b
$ PangoLayout -> IO (Maybe FontDescription)
layoutGetFontDescription PangoLayout
layout

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

  let win :: Window
win                 = WindowRef -> Editor -> Window
findWindowWith (View -> WindowRef
windowRef View
v) Editor
e
      [Double
width'', Double
height''] = (Int -> Double) -> [Int] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int
width', Int
height']
      lineHeight :: Double
lineHeight          = FontMetrics -> Double
ascent (View -> FontMetrics
metrics View
v) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ FontMetrics -> Double
descent (View -> FontMetrics
metrics View
v)
      winh :: Int
winh                = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
height'' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lineHeight)

      (Point
tos, Point
point, Text
text)  = Window
-> FBuffer -> BufferM (Point, Point, Text) -> (Point, Point, Text)
forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
win FBuffer
b (BufferM (Point, Point, Text) -> (Point, Point, Text))
-> BufferM (Point, Point, Text) -> (Point, Point, Text)
forall a b. (a -> b) -> a -> b
$ do
                              Point
from <- (Getting Point FBuffer Point -> BufferM Point
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting Point FBuffer Point -> BufferM Point)
-> (Mark -> Getting Point FBuffer Point) -> Mark -> BufferM Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mark -> Getting Point FBuffer Point
forall (f :: * -> *).
Functor f =>
Mark -> (Point -> f Point) -> FBuffer -> f FBuffer
markPointA) (Mark -> BufferM Point) -> BufferM Mark -> BufferM Point
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MarkSet Mark -> Mark
forall a. MarkSet a -> a
fromMark (MarkSet Mark -> Mark) -> BufferM (MarkSet Mark) -> BufferM Mark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufferM (MarkSet Mark)
askMarks
                              YiString
rope <- Direction -> Point -> BufferM YiString
streamB Direction
Forward Point
from
                              Point
p    <- BufferM Point
pointB
                              let content :: YiString
content = (YiString, YiString) -> YiString
forall a b. (a, b) -> a
fst ((YiString, YiString) -> YiString)
-> (YiString, YiString) -> YiString
forall a b. (a -> b) -> a -> b
$ Int -> YiString -> (YiString, YiString)
splitAtLine Int
winh YiString
rope
                              -- allow BOS offset to be just after the last line
                              let addNL :: YiString -> YiString
addNL = if YiString -> Int
R.countNewLines YiString
content Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
winh
                                          then YiString -> YiString
forall a. a -> a
id
                                          else (YiString -> Char -> YiString
`R.snoc` Char
'\n')
                              (Point, Point, Text) -> BufferM (Point, Point, Text)
forall a. a -> BufferM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point
from, Point
p, YiString -> Text
R.toText (YiString -> Text) -> YiString -> Text
forall a b. (a -> b) -> a -> b
$ YiString -> YiString
addNL YiString
content)

  Config
config   <- YiM Config -> ControlM Config
forall a. YiM a -> ControlM a
liftYi YiM Config
forall (m :: * -> *). MonadEditor m => m Config
askCfg
  if UIConfig -> Bool
configLineWrap (UIConfig -> Bool) -> UIConfig -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> UIConfig
configUI Config
config
    then do Maybe Double
oldWidth <- IO (Maybe Double) -> ControlM (Maybe Double)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Maybe Double) -> ControlM (Maybe Double))
-> IO (Maybe Double) -> ControlM (Maybe Double)
forall a b. (a -> b) -> a -> b
$ PangoLayout -> IO (Maybe Double)
layoutGetWidth PangoLayout
layout
            Bool -> ControlM () -> ControlM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Double
oldWidth Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double -> Maybe Double
forall a. a -> Maybe a
Just Double
width'') (ControlM () -> ControlM ()) -> ControlM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$
              IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ PangoLayout -> Maybe Double -> IO ()
layoutSetWidth PangoLayout
layout (Maybe Double -> IO ()) -> Maybe Double -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Maybe Double
forall a. a -> Maybe a
Just Double
width''
    else do
    (Rectangle Int
px Int
_py Int
pwidth Int
_pheight, Rectangle
_) <- IO (Rectangle, Rectangle) -> ControlM (Rectangle, Rectangle)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Rectangle, Rectangle) -> ControlM (Rectangle, Rectangle))
-> IO (Rectangle, Rectangle) -> ControlM (Rectangle, Rectangle)
forall a b. (a -> b) -> a -> b
$
                                             PangoLayout -> IO (Rectangle, Rectangle)
layoutGetPixelExtents PangoLayout
layout
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> Int -> Int -> IO ()
forall self. WidgetClass self => self -> Int -> Int -> IO ()
widgetSetSizeRequest (View -> DrawingArea
drawArea View
v) (Int
pxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
pwidth) (-Int
1)

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

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

updateCache :: Editor -> ControlM ()
updateCache :: Editor -> ControlM ()
updateCache Editor
e = do
    let tabs :: PointedList Tab
tabs = 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
    IORef [TabInfo]
cacheRef <- (Control -> IORef [TabInfo]) -> ControlM (IORef [TabInfo])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Control -> IORef [TabInfo]
tabCache
    [TabInfo]
cache <- IO [TabInfo] -> ControlM [TabInfo]
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO [TabInfo] -> ControlM [TabInfo])
-> IO [TabInfo] -> ControlM [TabInfo]
forall a b. (a -> b) -> a -> b
$ IORef [TabInfo] -> IO [TabInfo]
forall a. IORef a -> IO a
readIORef IORef [TabInfo]
cacheRef
    [TabInfo]
cache' <- Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs Editor
e (PointedList (Tab, Bool) -> [(Tab, Bool)]
forall a. PointedList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PointedList (Tab, Bool) -> [(Tab, Bool)])
-> PointedList (Tab, Bool) -> [(Tab, Bool)]
forall a b. (a -> b) -> a -> b
$ PointedList Tab -> PointedList (Tab, Bool)
forall a. PointedList a -> PointedList (a, Bool)
PL.withFocus PointedList Tab
tabs) [TabInfo]
cache
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ IORef [TabInfo] -> [TabInfo] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [TabInfo]
cacheRef [TabInfo]
cache'

syncTabs :: Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs :: Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs Editor
e (tfocused :: (Tab, Bool)
tfocused@(Tab
t,Bool
focused):[(Tab, Bool)]
ts) (TabInfo
c:[TabInfo]
cs)
    | Tab
t Tab -> Tab -> Bool
forall a. Eq a => a -> a -> Bool
== TabInfo -> Tab
coreTab TabInfo
c =
        do Bool -> ControlM () -> ControlM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
focused (ControlM () -> ControlM ()) -> ControlM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ TabInfo -> ControlM ()
setTabFocus TabInfo
c
--           let vCache = views c
           (:) (TabInfo -> [TabInfo] -> [TabInfo])
-> ControlM TabInfo -> ControlM ([TabInfo] -> [TabInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Editor -> TabInfo -> Tab -> ControlM TabInfo
syncTab Editor
e TabInfo
c Tab
t ControlM ([TabInfo] -> [TabInfo])
-> ControlM [TabInfo] -> ControlM [TabInfo]
forall a b. ControlM (a -> b) -> ControlM a -> ControlM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs Editor
e [(Tab, Bool)]
ts [TabInfo]
cs
    | Tab
t Tab -> [Tab] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TabInfo -> Tab) -> [TabInfo] -> [Tab]
forall a b. (a -> b) -> [a] -> [b]
map TabInfo -> Tab
coreTab [TabInfo]
cs =
        do TabInfo -> ControlM ()
removeTab TabInfo
c
           Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs Editor
e ((Tab, Bool)
tfocused(Tab, Bool) -> [(Tab, Bool)] -> [(Tab, Bool)]
forall a. a -> [a] -> [a]
:[(Tab, Bool)]
ts) [TabInfo]
cs
    | Bool
otherwise =
        do TabInfo
c' <- Editor -> Tab -> TabInfo -> ControlM TabInfo
insertTabBefore Editor
e Tab
t TabInfo
c
           Bool -> ControlM () -> ControlM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
focused (ControlM () -> ControlM ()) -> ControlM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ TabInfo -> ControlM ()
setTabFocus TabInfo
c'
           ([TabInfo] -> [TabInfo]) -> ControlM ([TabInfo] -> [TabInfo])
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TabInfo
c'TabInfo -> [TabInfo] -> [TabInfo]
forall a. a -> [a] -> [a]
:) ControlM ([TabInfo] -> [TabInfo])
-> ControlM [TabInfo] -> ControlM [TabInfo]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs Editor
e [(Tab, Bool)]
ts (TabInfo
cTabInfo -> [TabInfo] -> [TabInfo]
forall a. a -> [a] -> [a]
:[TabInfo]
cs)
syncTabs Editor
e [(Tab, Bool)]
ts [] = ((Tab, Bool) -> ControlM TabInfo)
-> [(Tab, Bool)] -> ControlM [TabInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Tab
t,Bool
focused) -> do
        TabInfo
c' <- Editor -> Tab -> ControlM TabInfo
insertTab Editor
e Tab
t
        Bool -> ControlM () -> ControlM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
focused (ControlM () -> ControlM ()) -> ControlM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ TabInfo -> ControlM ()
setTabFocus TabInfo
c'
        TabInfo -> ControlM TabInfo
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return TabInfo
c') [(Tab, Bool)]
ts
syncTabs Editor
_ [] [TabInfo]
cs = (TabInfo -> ControlM ()) -> [TabInfo] -> ControlM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TabInfo -> ControlM ()
removeTab [TabInfo]
cs ControlM () -> ControlM [TabInfo] -> ControlM [TabInfo]
forall a b. ControlM a -> ControlM b -> ControlM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [TabInfo] -> ControlM [TabInfo]
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return []

syncTab :: Editor -> TabInfo -> Tab -> ControlM TabInfo
syncTab :: Editor -> TabInfo -> Tab -> ControlM TabInfo
syncTab Editor
e TabInfo
tab Tab
ws =
  -- TODO Maybe do something here
  TabInfo -> ControlM TabInfo
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return TabInfo
tab

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

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

setWindowFocus :: Editor -> TabInfo -> View -> ControlM ()
setWindowFocus :: Editor -> TabInfo -> View -> ControlM ()
setWindowFocus Editor
e TabInfo
t View
v = do
  let bufferName :: Text
bufferName = Int -> FBuffer -> Text
shortIdentString ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ Editor -> [String]
commonNamePrefix Editor
e) (FBuffer -> Text) -> FBuffer -> Text
forall a b. (a -> b) -> a -> b
$
                   BufferRef -> Editor -> FBuffer
findBufferWith (View -> BufferRef
viewFBufRef View
v) Editor
e
      window :: Window
window = WindowRef -> Editor -> Window
findWindowWith (View -> WindowRef
windowRef View
v) Editor
e
      ml :: Text
ml = Window -> FBuffer -> BufferM Text -> Text
forall a. Window -> FBuffer -> BufferM a -> a
askBuffer Window
window (BufferRef -> Editor -> FBuffer
findBufferWith (View -> BufferRef
viewFBufRef View
v) 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)

-- TODO
--  update (textview w) widgetIsFocus True
--  update (modeline w) labelText ml
--  update (uiWindow ui) windowTitle $ bufferName <> " - Yi"
--  update (uiNotebook ui) (notebookChildTabLabel (page t))
--    (tabAbbrevTitle bufferName)
  () -> ControlM ()
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

removeTab :: TabInfo -> ControlM ()
removeTab :: TabInfo -> ControlM ()
removeTab TabInfo
t =
  -- TODO this needs to close the views in the tab with callback
  () -> ControlM ()
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

removeView :: TabInfo -> View -> ControlM ()
removeView :: TabInfo -> View -> ControlM ()
removeView TabInfo
tab View
view =
  -- TODO this needs to close the view with callback
  () -> ControlM ()
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

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

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

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

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

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

              return w
-}

reloadProject :: FilePath -> ControlM ()
reloadProject :: String -> ControlM ()
reloadProject String
_ = () -> ControlM ()
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

data Buffer = Buffer
    { Buffer -> BufferRef
fBufRef     :: BufferRef
    }

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

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

newBuffer :: BufferId -> R.YiString -> ControlM Buffer
newBuffer :: BufferId -> YiString -> ControlM Buffer
newBuffer BufferId
id YiString
text = do
    BufferRef
fBufRef <- YiM BufferRef -> ControlM BufferRef
forall a. YiM a -> ControlM a
liftYi (YiM BufferRef -> ControlM BufferRef)
-> (YiString -> YiM BufferRef) -> YiString -> ControlM BufferRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditorM BufferRef -> YiM BufferRef
forall a. EditorM a -> YiM a
forall (m :: * -> *) a. MonadEditor m => EditorM a -> m a
withEditor (EditorM BufferRef -> YiM BufferRef)
-> (YiString -> EditorM BufferRef) -> YiString -> YiM BufferRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferId -> YiString -> EditorM BufferRef
newBufferE BufferId
id (YiString -> ControlM BufferRef) -> YiString -> ControlM BufferRef
forall a b. (a -> b) -> a -> b
$ YiString
text
    Buffer -> ControlM Buffer
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer{BufferRef
fBufRef :: BufferRef
fBufRef :: BufferRef
..}

newView :: Buffer -> FontDescription -> ControlM View
newView :: Buffer -> FontDescription -> ControlM View
newView Buffer
buffer FontDescription
font = do
    Control
control  <- ControlM Control
forall r (m :: * -> *). MonadReader r m => m r
ask
    Config
config   <- YiM Config -> ControlM Config
forall a. YiM a -> ControlM a
liftYi YiM Config
forall (m :: * -> *). MonadEditor m => m Config
askCfg
    let viewFBufRef :: BufferRef
viewFBufRef = Buffer -> BufferRef
fBufRef Buffer
buffer
    Window
newWindow <-
      (Window -> Window) -> ControlM Window -> ControlM Window
forall a b. (a -> b) -> ControlM a -> ControlM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Window
w -> Window
w { height :: Int
height=Int
50
                    , winRegion :: Region
winRegion = Point -> Point -> Region
mkRegion (Int -> Point
Point Int
0) (Int -> Point
Point Int
2000)
                    }) (ControlM Window -> ControlM Window)
-> ControlM Window -> ControlM Window
forall a b. (a -> b) -> a -> b
$ YiM Window -> ControlM Window
forall a. YiM a -> ControlM a
liftYi (YiM Window -> ControlM Window) -> YiM Window -> ControlM Window
forall a b. (a -> b) -> a -> b
$ EditorM Window -> YiM Window
forall a. EditorM a -> YiM a
forall (m :: * -> *) a. MonadEditor m => EditorM a -> m a
withEditor (EditorM Window -> YiM Window) -> EditorM Window -> YiM Window
forall a b. (a -> b) -> a -> b
$ Bool -> BufferRef -> EditorM Window
newWindowE Bool
False BufferRef
viewFBufRef
    let windowRef :: WindowRef
windowRef = Window -> WindowRef
wkey Window
newWindow
    YiM () -> ControlM ()
forall a. YiM a -> ControlM a
liftYi (YiM () -> ControlM ()) -> YiM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ EditorM () -> YiM ()
forall a. EditorM a -> YiM a
forall (m :: * -> *) a. MonadEditor m => EditorM a -> m a
withEditor (EditorM () -> YiM ()) -> EditorM () -> YiM ()
forall a b. (a -> b) -> a -> b
$ do
        (PointedList Window -> Identity (PointedList Window))
-> Editor -> Identity Editor
Lens' Editor (PointedList Window)
windowsA ((PointedList Window -> Identity (PointedList Window))
 -> Editor -> Identity Editor)
-> (PointedList Window -> PointedList Window) -> EditorM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Window -> PointedList Window -> PointedList Window
forall a. a -> PointedList a -> PointedList a
PL.insertRight Window
newWindow
        Editor
e <- EditorM Editor
forall s (m :: * -> *). MonadState s m => m s
get
        Editor -> EditorM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Editor -> EditorM ()) -> Editor -> EditorM ()
forall a b. (a -> b) -> a -> b
$ Editor -> Editor
focusAllSyntax Editor
e
    DrawingArea
drawArea <- IO DrawingArea -> ControlM DrawingArea
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO DrawingArea
drawingAreaNew
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ())
-> (UIConfig -> IO ()) -> UIConfig -> ControlM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawingArea -> StateType -> Color -> IO ()
forall self.
WidgetClass self =>
self -> StateType -> Color -> IO ()
widgetModifyBg DrawingArea
drawArea 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 -> ControlM ()) -> UIConfig -> ControlM ()
forall a b. (a -> b) -> a -> b
$ Config -> UIConfig
configUI Config
config
    PangoContext
context  <- IO PangoContext -> ControlM PangoContext
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO PangoContext -> ControlM PangoContext)
-> IO PangoContext -> ControlM PangoContext
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO PangoContext
forall self. WidgetClass self => self -> IO PangoContext
widgetCreatePangoContext DrawingArea
drawArea
    PangoLayout
layout   <- IO PangoLayout -> ControlM PangoLayout
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO PangoLayout -> ControlM PangoLayout)
-> IO PangoLayout -> ControlM PangoLayout
forall a b. (a -> b) -> a -> b
$ PangoContext -> IO PangoLayout
layoutEmpty PangoContext
context
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ PangoLayout -> Maybe FontDescription -> IO ()
layoutSetFontDescription PangoLayout
layout (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
font)
    Language
language <- IO Language -> ControlM Language
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Language -> ControlM Language)
-> IO Language -> ControlM Language
forall a b. (a -> b) -> a -> b
$ PangoContext -> IO Language
contextGetLanguage PangoContext
context
    FontMetrics
metrics  <- IO FontMetrics -> ControlM FontMetrics
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO FontMetrics -> ControlM FontMetrics)
-> IO FontMetrics -> ControlM FontMetrics
forall a b. (a -> b) -> a -> b
$ PangoContext -> FontDescription -> Language -> IO FontMetrics
contextGetMetrics PangoContext
context FontDescription
font Language
language
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ PangoLayout -> Text -> IO ()
forall string. GlibString string => PangoLayout -> string -> IO ()
layoutSetText PangoLayout
layout (Text
"" :: Text)

    ScrolledWindow
scrollWin <- IO ScrolledWindow -> ControlM ScrolledWindow
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO ScrolledWindow -> ControlM ScrolledWindow)
-> IO ScrolledWindow -> ControlM ScrolledWindow
forall a b. (a -> b) -> a -> b
$ Maybe Adjustment -> Maybe Adjustment -> IO ScrolledWindow
scrolledWindowNew Maybe Adjustment
forall a. Maybe a
Nothing Maybe Adjustment
forall a. Maybe a
Nothing
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ do
        ScrolledWindow -> DrawingArea -> IO ()
forall self child.
(ScrolledWindowClass self, WidgetClass child) =>
self -> child -> IO ()
scrolledWindowAddWithViewport ScrolledWindow
scrollWin DrawingArea
drawArea
        ScrolledWindow -> PolicyType -> PolicyType -> IO ()
forall self.
ScrolledWindowClass self =>
self -> PolicyType -> PolicyType -> IO ()
scrolledWindowSetPolicy ScrolledWindow
scrollWin PolicyType
PolicyAutomatic PolicyType
PolicyNever

    Point
initialTos <-
      YiM Point -> ControlM Point
forall a. YiM a -> ControlM a
liftYi (YiM Point -> ControlM Point)
-> (BufferM Point -> YiM Point) -> BufferM Point -> ControlM Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditorM Point -> YiM Point
forall a. EditorM a -> YiM a
forall (m :: * -> *) a. MonadEditor m => EditorM a -> m a
withEditor (EditorM Point -> YiM Point)
-> (BufferM Point -> EditorM Point) -> BufferM Point -> YiM Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> BufferRef -> BufferM Point -> EditorM Point
forall (m :: * -> *) a.
MonadEditor m =>
Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow Window
newWindow BufferRef
viewFBufRef (BufferM Point -> ControlM Point)
-> BufferM Point -> ControlM Point
forall a b. (a -> b) -> a -> b
$
        (Getting Point FBuffer Point -> BufferM Point
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting Point FBuffer Point -> BufferM Point)
-> (Mark -> Getting Point FBuffer Point) -> Mark -> BufferM Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mark -> Getting Point FBuffer Point
forall (f :: * -> *).
Functor f =>
Mark -> (Point -> f Point) -> FBuffer -> f FBuffer
markPointA) (Mark -> BufferM Point) -> BufferM Mark -> BufferM Point
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MarkSet Mark -> Mark
forall a. MarkSet a -> a
fromMark (MarkSet Mark -> Mark) -> BufferM (MarkSet Mark) -> BufferM Mark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufferM (MarkSet Mark)
askMarks
    IORef Point
shownTos <- IO (IORef Point) -> ControlM (IORef Point)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (IORef Point) -> ControlM (IORef Point))
-> IO (IORef Point) -> ControlM (IORef Point)
forall a b. (a -> b) -> a -> b
$ Point -> IO (IORef Point)
forall a. a -> IO (IORef a)
newIORef Point
initialTos
    IORef (Maybe (ConnectId DrawingArea))
winMotionSignal <- IO (IORef (Maybe (ConnectId DrawingArea)))
-> ControlM (IORef (Maybe (ConnectId DrawingArea)))
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (IORef (Maybe (ConnectId DrawingArea)))
 -> ControlM (IORef (Maybe (ConnectId DrawingArea))))
-> IO (IORef (Maybe (ConnectId DrawingArea)))
-> ControlM (IORef (Maybe (ConnectId DrawingArea)))
forall a b. (a -> b) -> a -> b
$ Maybe (ConnectId DrawingArea)
-> IO (IORef (Maybe (ConnectId DrawingArea)))
forall a. a -> IO (IORef a)
newIORef Maybe (ConnectId DrawingArea)
forall a. Maybe a
Nothing

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

    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> [EventMask] -> IO ()
forall self. WidgetClass self => self -> [EventMask] -> IO ()
Gtk.widgetAddEvents DrawingArea
drawArea [EventMask
KeyPressMask]
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> [AttrOp DrawingArea] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
Gtk.set DrawingArea
drawArea [Attr DrawingArea Bool
forall self. WidgetClass self => Attr self Bool
Gtk.widgetCanFocus Attr DrawingArea Bool -> Bool -> AttrOp DrawingArea
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= Bool
True]

    IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea))
-> IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall a b. (a -> b) -> a -> b
$ DrawingArea
drawArea DrawingArea -> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall w.
WidgetClass w =>
w -> (Event -> IO Bool) -> IO (ConnectId w)
`Gtk.onKeyPress` \Event
event -> do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Yi Control Key Press = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Event -> String
forall a. Show a => a -> String
show Event
event
        ControlM () -> Control -> IO ()
forall a. ControlM a -> Control -> IO a
runControl (Action -> ControlM ()
runAction (Action -> ControlM ()) -> Action -> ControlM ()
forall a b. (a -> b) -> a -> b
$ EditorM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction (EditorM () -> Action) -> EditorM () -> Action
forall a b. (a -> b) -> a -> b
$ do
            WindowRef -> EditorM ()
focusWindowE WindowRef
windowRef
            BufferRef -> EditorM ()
switchToBufferE BufferRef
viewFBufRef) Control
control
        Bool
result <- ([Event] -> IO ()) -> Event -> IO Bool
processEvent (Yi -> [Event] -> IO ()
yiInput (Yi -> [Event] -> IO ()) -> Yi -> [Event] -> IO ()
forall a b. (a -> b) -> a -> b
$ Control -> Yi
controlYi Control
control) Event
event
        DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw DrawingArea
drawArea
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
result

    IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea))
-> IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall a b. (a -> b) -> a -> b
$ DrawingArea
drawArea DrawingArea -> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall w.
WidgetClass w =>
w -> (Event -> IO Bool) -> IO (ConnectId w)
`Gtk.onButtonPress` \Event
event -> do
        DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetGrabFocus DrawingArea
drawArea
        ControlM Bool -> Control -> IO Bool
forall a. ControlM a -> Control -> IO a
runControl (View -> Event -> ControlM Bool
handleClick View
view Event
event) Control
control

    IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea))
-> IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall a b. (a -> b) -> a -> b
$ DrawingArea
drawArea DrawingArea -> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall w.
WidgetClass w =>
w -> (Event -> IO Bool) -> IO (ConnectId w)
`Gtk.onButtonRelease` \Event
event ->
        ControlM Bool -> Control -> IO Bool
forall a. ControlM a -> Control -> IO a
runControl (View -> Event -> ControlM Bool
handleClick View
view Event
event) Control
control

    IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea))
-> IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall a b. (a -> b) -> a -> b
$ DrawingArea
drawArea DrawingArea -> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall w.
WidgetClass w =>
w -> (Event -> IO Bool) -> IO (ConnectId w)
`Gtk.onScroll` \Event
event ->
        ControlM Bool -> Control -> IO Bool
forall a. ControlM a -> Control -> IO a
runControl (View -> Event -> ControlM Bool
handleScroll View
view Event
event) Control
control

    IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea))
-> IO (ConnectId DrawingArea) -> ControlM (ConnectId DrawingArea)
forall a b. (a -> b) -> a -> b
$ DrawingArea
drawArea DrawingArea -> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall w.
WidgetClass w =>
w -> (Event -> IO Bool) -> IO (ConnectId w)
`Gtk.onExpose` \Event
event -> do
        (Text
text, [PangoAttribute]
allAttrs, ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
 Point, Point, Int)
debug, Point
tos, Point -> Int
rel, Point
point, Bool
inserting) <-
          ControlM
  (Text, [PangoAttribute],
   ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
    Point, Point, Int),
   Point, Point -> Int, Point, Bool)
-> Control
-> IO
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall a. ControlM a -> Control -> IO a
runControl (YiM
  (Text, [PangoAttribute],
   ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
    Point, Point, Int),
   Point, Point -> Int, Point, Bool)
-> ControlM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall a. YiM a -> ControlM a
liftYi (YiM
   (Text, [PangoAttribute],
    ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
     Point, Point, Int),
    Point, Point -> Int, Point, Bool)
 -> ControlM
      (Text, [PangoAttribute],
       ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
        Point, Point, Int),
       Point, Point -> Int, Point, Bool))
-> YiM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
-> ControlM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall a b. (a -> b) -> a -> b
$ EditorM
  (Text, [PangoAttribute],
   ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
    Point, Point, Int),
   Point, Point -> Int, Point, Bool)
-> YiM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall a. EditorM a -> YiM a
forall (m :: * -> *) a. MonadEditor m => EditorM a -> m a
withEditor (EditorM
   (Text, [PangoAttribute],
    ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
     Point, Point, Int),
    Point, Point -> Int, Point, Bool)
 -> YiM
      (Text, [PangoAttribute],
       ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
        Point, Point, Int),
       Point, Point -> Int, Point, Bool))
-> EditorM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
-> YiM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall a b. (a -> b) -> a -> b
$ do
            Window
window <- WindowRef -> Editor -> Window
findWindowWith WindowRef
windowRef (Editor -> Window) -> EditorM Editor -> EditorM Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EditorM Editor
forall s (m :: * -> *). MonadState s m => m s
get
            ASetter
  Editor Editor (Map BufferRef FBuffer) (Map BufferRef FBuffer)
-> (Map BufferRef FBuffer -> Map BufferRef FBuffer) -> EditorM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
(%=) ASetter
  Editor Editor (Map BufferRef FBuffer) (Map BufferRef FBuffer)
Lens' Editor (Map BufferRef FBuffer)
buffersA ((FBuffer -> FBuffer)
-> Map BufferRef FBuffer -> Map BufferRef FBuffer
forall a b. (a -> b) -> Map BufferRef a -> Map BufferRef b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FBuffer -> FBuffer
clearSyntax (FBuffer -> FBuffer) -> (FBuffer -> FBuffer) -> FBuffer -> FBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FBuffer -> FBuffer
clearHighlight))
            let winh :: Int
winh = Window -> Int
height Window
window
            let tos :: Point
tos = Point -> Point -> Point
forall a. Ord a => a -> a -> a
max Point
0 (Region -> Point
regionStart (Window -> Region
winRegion Window
window))
            let bos :: Point
bos = Region -> Point
regionEnd (Window -> Region
winRegion Window
window)
            let rel :: Point -> b
rel Point
p = Point -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Point
p Point -> Point -> Point
forall a. Num a => a -> a -> a
- Point
tos)

            Window
-> BufferRef
-> BufferM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
-> EditorM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall (m :: * -> *) a.
MonadEditor m =>
Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow Window
window BufferRef
viewFBufRef (BufferM
   (Text, [PangoAttribute],
    ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
     Point, Point, Int),
    Point, Point -> Int, Point, Bool)
 -> EditorM
      (Text, [PangoAttribute],
       ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
        Point, Point, Int),
       Point, Point -> Int, Point, Bool))
-> BufferM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
-> EditorM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall a b. (a -> b) -> a -> b
$ do
                -- tos       <- getMarkPointB =<< fromMark <$> askMarks
                YiString
rope      <- Direction -> Point -> BufferM YiString
streamB Direction
Forward Point
tos
                Point
point     <- BufferM Point
pointB
                Bool
inserting <- Getting Bool FBuffer Bool -> BufferM Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool FBuffer Bool
forall c. HasAttributes c => Lens' c Bool
Lens' FBuffer Bool
insertingA

                Text
modeNm <- (FBuffer -> Text) -> BufferM Text
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((forall syntax. Mode syntax -> Text) -> FBuffer -> Text
forall a. (forall syntax. Mode syntax -> a) -> FBuffer -> a
withMode0 Mode syntax -> Text
forall syntax. Mode syntax -> Text
modeName)

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

                [(Point, Attributes)]
picture <- UIStyle
-> Maybe SearchExp -> Region -> BufferM [(Point, Attributes)]
attributesPictureAndSelB UIStyle
sty Maybe SearchExp
forall a. Maybe a
Nothing
                           (Point -> Point -> Region
mkRegion Point
tos Point
bos)

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

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


                (Text, [PangoAttribute],
 ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
  Point, Point, Int),
 Point, Point -> Int, Point, Bool)
-> BufferM
     (Text, [PangoAttribute],
      ([(Point, Attributes)], [(Point, Attributes, Point)], Text, Window,
       Point, Point, Int),
      Point, Point -> Int, Point, Bool)
forall a. a -> BufferM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
text, [PangoAttribute]
allAttrs, ([(Point, Attributes)]
picture, [(Point, Attributes, Point)]
strokes, Text
modeNm,
                                         Window
window, Point
tos, Point
bos, Int
winh),
                        Point
tos, Point -> Int
forall {b}. Num b => Point -> b
rel, Point
point, Bool
inserting)) Control
control

        -- putStrLn $ "Setting Layout Attributes " <> show debug
        PangoLayout -> [PangoAttribute] -> IO ()
layoutSetAttributes PangoLayout
layout [PangoAttribute]
allAttrs
        -- putStrLn "Done Stting Layout Attributes"
        DrawWindow
dw      <- DrawingArea -> IO DrawWindow
forall widget. WidgetClass widget => widget -> IO DrawWindow
widgetGetDrawWindow DrawingArea
drawArea
        GC
gc      <- DrawWindow -> IO GC
forall d. DrawableClass d => d -> IO GC
gcNew DrawWindow
dw
        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
text Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
oldText) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PangoLayout -> Text -> IO ()
forall string. GlibString string => PangoLayout -> string -> IO ()
layoutSetText PangoLayout
layout Text
text
        DrawWindow -> GC -> Int -> Int -> PangoLayout -> IO ()
forall d.
DrawableClass d =>
d -> GC -> Int -> Int -> PangoLayout -> IO ()
drawLayout DrawWindow
dw GC
gc Int
0 Int
0 PangoLayout
layout
        IO () -> IO ()
forall α. IO α -> IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Point -> Point -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Point
shownTos Point
tos

        -- paint the cursor
        (PangoRectangle Double
curx Double
cury Double
curw Double
curh, PangoRectangle
_) <-
          PangoLayout -> Int -> IO (PangoRectangle, PangoRectangle)
layoutGetCursorPos PangoLayout
layout (Point -> Int
rel Point
point)
        PangoRectangle Double
chx Double
chy Double
chw Double
chh          <-
          PangoLayout -> Int -> IO PangoRectangle
layoutIndexToPos PangoLayout
layout (Point -> Int
rel Point
point)

        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
$
                                          Config -> UIConfig
configUI Config
config })
        if Bool
inserting
          then DrawWindow -> GC -> (Int, Int) -> (Int, Int) -> IO ()
forall d.
DrawableClass d =>
d -> GC -> (Int, Int) -> (Int, Int) -> IO ()
drawLine DrawWindow
dw GC
gc (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
curx, Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
cury) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
curx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
curw, Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
cury Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
curh)
          else DrawWindow -> GC -> Bool -> Int -> Int -> Int -> Int -> IO ()
forall d.
DrawableClass d =>
d -> GC -> Bool -> Int -> Int -> Int -> Int -> IO ()
drawRectangle DrawWindow
dw GC
gc Bool
False (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chx) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chy) (if Double
chw Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chw else Int
8) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
chh)

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

    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetGrabFocus DrawingArea
drawArea

    IORef [TabInfo]
tabsRef <- (Control -> IORef [TabInfo]) -> ControlM (IORef [TabInfo])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Control -> IORef [TabInfo]
tabCache
    [TabInfo]
ts <- IO [TabInfo] -> ControlM [TabInfo]
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO [TabInfo] -> ControlM [TabInfo])
-> IO [TabInfo] -> ControlM [TabInfo]
forall a b. (a -> b) -> a -> b
$ IORef [TabInfo] -> IO [TabInfo]
forall a. IORef a -> IO a
readIORef IORef [TabInfo]
tabsRef
    -- TODO: the Tab idkey should be assigned using
    -- Yi.Editor.newRef. But we can't modify that here, since our
    -- access to 'Yi' is readonly.
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ IORef [TabInfo] -> [TabInfo] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [TabInfo]
tabsRef (Tab -> TabInfo
TabInfo (Int -> Window -> Tab
makeTab1 Int
0 Window
newWindow)TabInfo -> [TabInfo] -> [TabInfo]
forall a. a -> [a] -> [a]
:[TabInfo]
ts)

    IORef (Map WindowRef View)
viewsRef <- (Control -> IORef (Map WindowRef View))
-> ControlM (IORef (Map WindowRef View))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Control -> IORef (Map WindowRef View)
views
    Map WindowRef View
vs <- IO (Map WindowRef View) -> ControlM (Map WindowRef View)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Map WindowRef View) -> ControlM (Map WindowRef View))
-> IO (Map WindowRef View) -> ControlM (Map WindowRef View)
forall a b. (a -> b) -> a -> b
$ IORef (Map WindowRef View) -> IO (Map WindowRef View)
forall a. IORef a -> IO a
readIORef IORef (Map WindowRef View)
viewsRef
    IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ IORef (Map WindowRef View) -> Map WindowRef View -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map WindowRef View)
viewsRef (Map WindowRef View -> IO ()) -> Map WindowRef View -> IO ()
forall a b. (a -> b) -> a -> b
$ WindowRef -> View -> Map WindowRef View -> Map WindowRef View
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert WindowRef
windowRef View
view Map WindowRef View
vs

    View -> ControlM View
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return View
view
  where
    clearHighlight :: FBuffer -> FBuffer
clearHighlight FBuffer
fb =
      -- if there were updates, then hide the selection.
      let h :: Bool
h = Getting Bool FBuffer Bool -> FBuffer -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool FBuffer Bool
Lens' FBuffer Bool
highlightSelectionA FBuffer
fb
          us :: Seq UIUpdate
us = Getting (Seq UIUpdate) FBuffer (Seq UIUpdate)
-> FBuffer -> Seq UIUpdate
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Seq UIUpdate) FBuffer (Seq UIUpdate)
forall c. HasAttributes c => Lens' c (Seq UIUpdate)
Lens' FBuffer (Seq UIUpdate)
pendingUpdatesA FBuffer
fb
      in (Bool -> Identity Bool) -> FBuffer -> Identity FBuffer
Lens' FBuffer Bool
highlightSelectionA ((Bool -> Identity Bool) -> FBuffer -> Identity FBuffer)
-> Bool -> FBuffer -> FBuffer
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Bool
h Bool -> Bool -> Bool
&& Seq UIUpdate -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq UIUpdate
us) (FBuffer -> FBuffer) -> FBuffer -> FBuffer
forall a b. (a -> b) -> a -> b
$ FBuffer
fb

{-# ANN setBufferMode ("HLint: ignore Redundant do" :: String) #-}
setBufferMode :: FilePath -> Buffer -> ControlM ()
setBufferMode :: String -> Buffer -> ControlM ()
setBufferMode String
f Buffer
buffer = do
    let bufRef :: BufferRef
bufRef = Buffer -> BufferRef
fBufRef Buffer
buffer
    -- adjust the mode
    [AnyMode]
tbl <- YiM [AnyMode] -> ControlM [AnyMode]
forall a. YiM a -> ControlM a
liftYi (YiM [AnyMode] -> ControlM [AnyMode])
-> YiM [AnyMode] -> ControlM [AnyMode]
forall a b. (a -> b) -> a -> b
$ (Yi -> [AnyMode]) -> YiM [AnyMode]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config -> [AnyMode]
modeTable (Config -> [AnyMode]) -> (Yi -> Config) -> Yi -> [AnyMode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Yi -> Config
yiConfig)
    YiString
contents <- YiM YiString -> ControlM YiString
forall a. YiM a -> ControlM a
liftYi (YiM YiString -> ControlM YiString)
-> YiM YiString -> ControlM YiString
forall a b. (a -> b) -> a -> b
$ BufferRef -> BufferM YiString -> YiM YiString
forall (m :: * -> *) a.
MonadEditor m =>
BufferRef -> BufferM a -> m a
withGivenBuffer BufferRef
bufRef BufferM YiString
elemsB
    let header :: String
header = YiString -> String
R.toString (YiString -> String) -> YiString -> String
forall a b. (a -> b) -> a -> b
$ Int -> YiString -> YiString
R.take Int
1024 YiString
contents
        hmode :: Text
hmode = case String
header String -> String -> AllTextSubmatches [] String
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (String
"\\-\\*\\- *([^ ]*) *\\-\\*\\-" :: String) of
            AllTextSubmatches [String
_,String
m] -> String -> Text
T.pack String
m
            AllTextSubmatches [] String
_ -> Text
""
        Just AnyMode
mode = (AnyMode -> Bool) -> [AnyMode] -> Maybe AnyMode
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(AnyMode Mode syntax
m)-> Mode syntax -> Text
forall syntax. Mode syntax -> Text
modeName Mode syntax
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
hmode) [AnyMode]
tbl Maybe AnyMode -> Maybe AnyMode -> Maybe AnyMode
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                    (AnyMode -> Bool) -> [AnyMode] -> Maybe AnyMode
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(AnyMode Mode syntax
m)-> Mode syntax -> String -> YiString -> Bool
forall syntax. Mode syntax -> String -> YiString -> Bool
modeApplies Mode syntax
m String
f YiString
contents) [AnyMode]
tbl Maybe AnyMode -> Maybe AnyMode -> Maybe AnyMode
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                    AnyMode -> Maybe AnyMode
forall a. a -> Maybe a
Just (Mode Any -> AnyMode
forall syntax. Mode syntax -> AnyMode
AnyMode Mode Any
forall syntax. Mode syntax
emptyMode)
    case AnyMode
mode of
        AnyMode Mode syntax
newMode -> do
            -- liftBase $ putStrLn $ show (f, modeName newMode)
            YiM () -> ControlM ()
forall a. YiM a -> ControlM a
liftYi (YiM () -> ControlM ()) -> YiM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ EditorM () -> YiM ()
forall a. EditorM a -> YiM a
forall (m :: * -> *) a. MonadEditor m => EditorM a -> m a
withEditor (EditorM () -> YiM ()) -> EditorM () -> YiM ()
forall a b. (a -> b) -> a -> b
$ do
                BufferRef -> BufferM () -> EditorM ()
forall (m :: * -> *) a.
MonadEditor m =>
BufferRef -> BufferM a -> m a
withGivenBuffer BufferRef
bufRef (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$ do
                    Mode syntax -> BufferM ()
forall syntax. Mode syntax -> BufferM ()
setMode Mode syntax
newMode
                    (FBuffer -> FBuffer) -> BufferM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify FBuffer -> FBuffer
clearSyntax
                BufferRef -> EditorM ()
switchToBufferE BufferRef
bufRef
            -- withEditor focusAllSyntax

withBuffer :: Buffer -> BufferM a -> ControlM a
withBuffer :: forall a. Buffer -> BufferM a -> ControlM a
withBuffer Buffer{fBufRef :: Buffer -> BufferRef
fBufRef = BufferRef
b} BufferM a
f = YiM a -> ControlM a
forall a. YiM a -> ControlM a
liftYi (YiM a -> ControlM a) -> YiM a -> ControlM a
forall a b. (a -> b) -> a -> b
$ BufferRef -> BufferM a -> YiM a
forall (m :: * -> *) a.
MonadEditor m =>
BufferRef -> BufferM a -> m a
withGivenBuffer BufferRef
b BufferM a
f

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

setText :: Buffer -> YiString -> ControlM ()
setText :: Buffer -> YiString -> ControlM ()
setText Buffer
b YiString
text = Buffer -> BufferM () -> ControlM ()
forall a. Buffer -> BufferM a -> ControlM a
withBuffer Buffer
b (BufferM () -> ControlM ()) -> BufferM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ do
    Region
r <- TextUnit -> BufferM Region
regionOfB TextUnit
Document
    Region -> YiString -> BufferM ()
replaceRegionB Region
r YiString
text

getText :: Buffer -> Iter -> Iter -> ControlM Text
getText :: Buffer -> Iter -> Iter -> ControlM Text
getText Buffer
b Iter{point :: Iter -> Point
point = Point
p1} Iter{point :: Iter -> Point
point = Point
p2} =
  (YiString -> Text) -> ControlM YiString -> ControlM Text
forall a b. (a -> b) -> ControlM a -> ControlM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap YiString -> Text
toText (ControlM YiString -> ControlM Text)
-> (Region -> ControlM YiString) -> Region -> ControlM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffer -> BufferM YiString -> ControlM YiString
forall a. Buffer -> BufferM a -> ControlM a
withBuffer Buffer
b (BufferM YiString -> ControlM YiString)
-> (Region -> BufferM YiString) -> Region -> ControlM YiString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Region -> BufferM YiString
readRegionB (Region -> ControlM Text) -> Region -> ControlM Text
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Region
mkRegion Point
p1 Point
p2

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

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

  Text -> ControlM ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn (Text -> ControlM ()) -> Text -> ControlM ()
forall a b. (a -> b) -> a -> b
$ Text
"Click: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Double, Double, Click) -> Text
forall a. Show a => a -> Text
showT (Event -> Double
Gdk.Events.eventX Event
event,
                                    Event -> Double
Gdk.Events.eventY Event
event,
                                    Event -> Click
Gdk.Events.eventClick Event
event)

  -- retrieve the clicked offset.
  (Bool
_,Int
layoutIndex,Int
_) <- IO (Bool, Int, Int) -> ControlM (Bool, Int, Int)
forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io (IO (Bool, Int, Int) -> ControlM (Bool, Int, Int))
-> IO (Bool, Int, Int) -> ControlM (Bool, Int, Int)
forall a b. (a -> b) -> a -> b
$ PangoLayout -> Double -> Double -> IO (Bool, Int, Int)
layoutXYToIndex (View -> PangoLayout
layout View
view)
                       (Event -> Double
Gdk.Events.eventX Event
event) (Event -> Double
Gdk.Events.eventY Event
event)
  Point
tos <- IO Point -> ControlM Point
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Point -> ControlM Point) -> IO Point -> ControlM Point
forall a b. (a -> b) -> a -> b
$ IORef Point -> IO Point
forall a. IORef a -> IO a
readIORef (View -> IORef Point
shownTos View
view)
  let p1 :: Point
p1 = Point
tos Point -> Point -> Point
forall a. Num a => a -> a -> a
+ Int -> Point
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
layoutIndex

  let winRef :: WindowRef
winRef = View -> WindowRef
windowRef View
view

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

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

  IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ case (Event -> Click
Gdk.Events.eventClick Event
event, Event -> MouseButton
Gdk.Events.eventButton Event
event) of
     (Click
Gdk.Events.SingleClick, MouseButton
Gdk.Events.LeftButton) -> do
        ConnectId DrawingArea
cid <- DrawingArea
-> Bool -> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall w.
WidgetClass w =>
w -> Bool -> (Event -> IO Bool) -> IO (ConnectId w)
onMotionNotify (View -> DrawingArea
drawArea View
view) Bool
False ((Event -> IO Bool) -> IO (ConnectId DrawingArea))
-> (Event -> IO Bool) -> IO (ConnectId DrawingArea)
forall a b. (a -> b) -> a -> b
$ \Event
event ->
            ControlM Bool -> Control -> IO Bool
forall a. ControlM a -> Control -> IO a
runControl (View -> Point -> Event -> ControlM Bool
handleMove View
view Point
p1 Event
event) Control
control
        IORef (Maybe (ConnectId DrawingArea))
-> Maybe (ConnectId DrawingArea) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (View -> IORef (Maybe (ConnectId DrawingArea))
winMotionSignal View
view) (Maybe (ConnectId DrawingArea) -> IO ())
-> Maybe (ConnectId DrawingArea) -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnectId DrawingArea -> Maybe (ConnectId DrawingArea)
forall a. a -> Maybe a
Just ConnectId DrawingArea
cid

     (Click, MouseButton)
_ -> do
       IO ()
-> (ConnectId DrawingArea -> IO ())
-> Maybe (ConnectId DrawingArea)
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ConnectId DrawingArea -> IO ()
forall obj. GObjectClass obj => ConnectId obj -> IO ()
signalDisconnect (Maybe (ConnectId DrawingArea) -> IO ())
-> IO (Maybe (ConnectId DrawingArea)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Maybe (ConnectId DrawingArea))
-> IO (Maybe (ConnectId DrawingArea))
forall a. IORef a -> IO a
readIORef (View -> IORef (Maybe (ConnectId DrawingArea))
winMotionSignal View
view)
       IORef (Maybe (ConnectId DrawingArea))
-> Maybe (ConnectId DrawingArea) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (View -> IORef (Maybe (ConnectId DrawingArea))
winMotionSignal View
view) Maybe (ConnectId DrawingArea)
forall a. Maybe a
Nothing

  case (Event -> Click
Gdk.Events.eventClick Event
event, Event -> MouseButton
Gdk.Events.eventButton Event
event) of
    (Click
Gdk.Events.SingleClick, MouseButton
Gdk.Events.LeftButton) ->
      Action -> ControlM ()
runAction (Action -> ControlM ())
-> (EditorM () -> Action) -> EditorM () -> ControlM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditorM () -> Action
forall a. Show a => EditorM a -> Action
EditorA (EditorM () -> ControlM ()) -> EditorM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ do
        -- b <- gets $ (bkey . findBufferWith (viewFBufRef view))
        -- focusWindow
        Window
window <- WindowRef -> Editor -> Window
findWindowWith WindowRef
winRef (Editor -> Window) -> EditorM Editor -> EditorM Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EditorM Editor
forall s (m :: * -> *). MonadState s m => m s
get
        Window -> BufferRef -> BufferM () -> EditorM ()
forall (m :: * -> *) a.
MonadEditor m =>
Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow Window
window (View -> BufferRef
viewFBufRef View
view) (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$ do
            Point -> BufferM ()
moveTo Point
p1
            Bool -> BufferM ()
setVisibleSelection Bool
False
    -- (Gdk.Events.SingleClick, _) -> runAction focusWindow
    (Click
Gdk.Events.ReleaseClick, MouseButton
Gdk.Events.MiddleButton) -> do
        Display
disp <- IO Display -> ControlM Display
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Display -> ControlM Display) -> IO Display -> ControlM Display
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO Display
forall self. WidgetClass self => self -> IO Display
widgetGetDisplay (View -> DrawingArea
drawArea View
view)
        Clipboard
cb <- IO Clipboard -> ControlM Clipboard
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Clipboard -> ControlM Clipboard)
-> IO Clipboard -> ControlM Clipboard
forall a b. (a -> b) -> a -> b
$ Display -> SelectionTag -> IO Clipboard
clipboardGetForDisplay Display
disp SelectionTag
selectionPrimary
        let cbHandler :: Maybe R.YiString -> IO ()
            cbHandler :: Maybe YiString -> IO ()
cbHandler Maybe YiString
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            cbHandler (Just YiString
txt) = ControlM () -> Control -> IO ()
forall a. ControlM a -> Control -> IO a
runControl (Action -> ControlM ()
runAction (Action -> ControlM ())
-> (EditorM () -> Action) -> EditorM () -> ControlM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditorM () -> Action
forall a. Show a => EditorM a -> Action
EditorA (EditorM () -> ControlM ()) -> EditorM () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ do
                Window
window <- WindowRef -> Editor -> Window
findWindowWith WindowRef
winRef (Editor -> Window) -> EditorM Editor -> EditorM Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EditorM Editor
forall s (m :: * -> *). MonadState s m => m s
get
                Window -> BufferRef -> BufferM () -> EditorM ()
forall (m :: * -> *) a.
MonadEditor m =>
Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow Window
window (View -> BufferRef
viewFBufRef View
view) (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$ do
                    BufferM Point
pointB BufferM Point -> (Point -> BufferM ()) -> BufferM ()
forall a b. BufferM a -> (a -> BufferM b) -> BufferM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Point -> BufferM ()
setSelectionMarkPointB
                    Point -> BufferM ()
moveTo Point
p1
                    YiString -> BufferM ()
insertN YiString
txt) Control
control
        IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ Clipboard -> (Maybe Text -> IO ()) -> IO ()
forall self string.
(ClipboardClass self, GlibString string) =>
self -> (Maybe string -> IO ()) -> IO ()
clipboardRequestText Clipboard
cb (Maybe YiString -> IO ()
cbHandler (Maybe YiString -> IO ())
-> (Maybe Text -> Maybe YiString) -> Maybe Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> YiString) -> Maybe Text -> Maybe YiString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> YiString
R.fromText)
    (Click, MouseButton)
_ -> () -> ControlM ()
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw (View -> DrawingArea
drawArea View
view)
  Bool -> ControlM Bool
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

handleScroll :: View -> Gdk.Events.Event -> ControlM Bool
handleScroll :: View -> Event -> ControlM Bool
handleScroll View
view Event
event = do
  let editorAction :: EditorM ()
editorAction =
        BufferM () -> EditorM ()
forall (m :: * -> *) a. MonadEditor m => BufferM a -> m a
withCurrentBuffer (BufferM () -> EditorM ()) -> BufferM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$ Int -> BufferM ()
vimScrollB (Int -> BufferM ()) -> Int -> BufferM ()
forall a b. (a -> b) -> a -> b
$ case Event -> ScrollDirection
Gdk.Events.eventDirection Event
event of
                        ScrollDirection
Gdk.Events.ScrollUp   -> -Int
1
                        ScrollDirection
Gdk.Events.ScrollDown -> Int
1
                        ScrollDirection
_ -> Int
0 -- Left/right scrolling not supported

  Action -> ControlM ()
runAction (Action -> ControlM ()) -> Action -> ControlM ()
forall a b. (a -> b) -> a -> b
$ EditorM () -> Action
forall a. Show a => EditorM a -> Action
EditorA EditorM ()
editorAction
  IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw (View -> DrawingArea
drawArea View
view)
  Bool -> ControlM Bool
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

handleMove :: View -> Point -> Gdk.Events.Event -> ControlM Bool
handleMove :: View -> Point -> Event -> ControlM Bool
handleMove View
view Point
p0 Event
event = do
  Text -> ControlM ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn (Text -> ControlM ()) -> Text -> ControlM ()
forall a b. (a -> b) -> a -> b
$ Text
"Motion: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Double, Double) -> Text
forall a. Show a => a -> Text
showT (Event -> Double
Gdk.Events.eventX Event
event,
                                     Event -> Double
Gdk.Events.eventY Event
event)

  -- retrieve the clicked offset.
  (Bool
_,Int
layoutIndex,Int
_) <-
    IO (Bool, Int, Int) -> ControlM (Bool, Int, Int)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Bool, Int, Int) -> ControlM (Bool, Int, Int))
-> IO (Bool, Int, Int) -> ControlM (Bool, Int, Int)
forall a b. (a -> b) -> a -> b
$ PangoLayout -> Double -> Double -> IO (Bool, Int, Int)
layoutXYToIndex (View -> PangoLayout
layout View
view)
    (Event -> Double
Gdk.Events.eventX Event
event) (Event -> Double
Gdk.Events.eventY Event
event)
  Point
tos <- IO Point -> ControlM Point
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Point -> ControlM Point) -> IO Point -> ControlM Point
forall a b. (a -> b) -> a -> b
$ IORef Point -> IO Point
forall a. IORef a -> IO a
readIORef (View -> IORef Point
shownTos View
view)
  let p1 :: Point
p1 = Point
tos Point -> Point -> Point
forall a. Num a => a -> a -> a
+ Int -> Point
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
layoutIndex


  let editorAction :: EditorM ()
editorAction = do
        Maybe YiString
txt <- BufferM (Maybe YiString) -> EditorM (Maybe YiString)
forall (m :: * -> *) a. MonadEditor m => BufferM a -> m a
withCurrentBuffer (BufferM (Maybe YiString) -> EditorM (Maybe YiString))
-> BufferM (Maybe YiString) -> EditorM (Maybe YiString)
forall a b. (a -> b) -> a -> b
$
           if Point
p0 Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
/= Point
p1
            then YiString -> Maybe YiString
forall a. a -> Maybe a
Just (YiString -> Maybe YiString)
-> BufferM YiString -> BufferM (Maybe YiString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              Mark
m <- MarkSet Mark -> Mark
forall a. MarkSet a -> a
selMark (MarkSet Mark -> Mark) -> BufferM (MarkSet Mark) -> BufferM Mark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufferM (MarkSet Mark)
askMarks
              Mark -> (Point -> Identity Point) -> FBuffer -> Identity FBuffer
forall (f :: * -> *).
Functor f =>
Mark -> (Point -> f Point) -> FBuffer -> f FBuffer
markPointA Mark
m ((Point -> Identity Point) -> FBuffer -> Identity FBuffer)
-> Point -> BufferM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Point
p0
              Point -> BufferM ()
moveTo Point
p1
              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
            else Maybe YiString -> BufferM (Maybe YiString)
forall a. a -> BufferM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe YiString
forall a. Maybe a
Nothing
        EditorM ()
-> (YiString -> EditorM ()) -> Maybe YiString -> EditorM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> EditorM ()
forall a. a -> EditorM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) YiString -> EditorM ()
setRegE Maybe YiString
txt

  Action -> ControlM ()
runAction (Action -> ControlM ()) -> Action -> ControlM ()
forall a b. (a -> b) -> a -> b
$ EditorM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction EditorM ()
editorAction
  -- drawWindowGetPointer (textview w) -- be ready for next message.

  -- Relies on uiActionCh being synchronous
  IORef YiString
selection <- IO (IORef YiString) -> ControlM (IORef YiString)
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (IORef YiString) -> ControlM (IORef YiString))
-> IO (IORef YiString) -> ControlM (IORef YiString)
forall a b. (a -> b) -> a -> b
$ YiString -> IO (IORef YiString)
forall a. a -> IO (IORef a)
newIORef YiString
""
  let yiAction :: YiM ()
yiAction = do
        YiString
txt <- BufferM YiString -> YiM YiString
forall (m :: * -> *) a. MonadEditor m => BufferM a -> m a
withCurrentBuffer (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)
             :: YiM R.YiString
        IO () -> YiM ()
forall α. IO α -> YiM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> YiM ()) -> IO () -> YiM ()
forall a b. (a -> b) -> a -> b
$ IORef YiString -> YiString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef YiString
selection YiString
txt
  Action -> ControlM ()
runAction (Action -> ControlM ()) -> Action -> ControlM ()
forall a b. (a -> b) -> a -> b
$ YiM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction YiM ()
yiAction
  YiString
txt <- IO YiString -> ControlM YiString
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO YiString -> ControlM YiString)
-> IO YiString -> ControlM YiString
forall a b. (a -> b) -> a -> b
$ IORef YiString -> IO YiString
forall a. IORef a -> IO a
readIORef IORef YiString
selection

  Display
disp <- IO Display -> ControlM Display
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Display -> ControlM Display) -> IO Display -> ControlM Display
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO Display
forall self. WidgetClass self => self -> IO Display
widgetGetDisplay (View -> DrawingArea
drawArea View
view)
  Clipboard
cb <- IO Clipboard -> ControlM Clipboard
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Clipboard -> ControlM Clipboard)
-> IO Clipboard -> ControlM Clipboard
forall a b. (a -> b) -> a -> b
$ Display -> SelectionTag -> IO Clipboard
clipboardGetForDisplay Display
disp SelectionTag
selectionPrimary
  IO Bool -> ControlM Bool
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Bool -> ControlM Bool) -> IO Bool -> ControlM Bool
forall a b. (a -> b) -> a -> b
$ Clipboard
-> [(SelectionTag, InfoId)]
-> (InfoId -> SelectionDataM ())
-> IO ()
-> IO Bool
forall self.
ClipboardClass self =>
self
-> [(SelectionTag, InfoId)]
-> (InfoId -> SelectionDataM ())
-> IO ()
-> IO Bool
clipboardSetWithData Clipboard
cb [(SelectionTag
targetString,InfoId
0)]
      (\InfoId
0 -> ReaderT (Ptr ()) IO Bool -> SelectionDataM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> ReaderT (Ptr ()) IO Bool
forall string.
GlibString string =>
string -> ReaderT (Ptr ()) IO Bool
selectionDataSetText (Text -> ReaderT (Ptr ()) IO Bool)
-> Text -> ReaderT (Ptr ()) IO Bool
forall a b. (a -> b) -> a -> b
$ YiString -> Text
R.toText YiString
txt)) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

  IO () -> ControlM ()
forall α. IO α -> ControlM α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ControlM ()) -> IO () -> ControlM ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetQueueDraw (View -> DrawingArea
drawArea View
view)
  Bool -> ControlM Bool
forall a. a -> ControlM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

processEvent :: ([Event] -> IO ()) -> Gdk.Events.Event -> IO Bool
processEvent :: ([Event] -> IO ()) -> Event -> IO Bool
processEvent [Event] -> IO ()
ch Event
ev = do
  -- logPutStrLn $ "Gtk.Event: " <> show ev
  -- logPutStrLn $ "Event: " <> show (gtkToYiEvent ev)
  case Event -> Maybe Event
gtkToYiEvent Event
ev of
    Maybe Event
Nothing -> Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Event not translatable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Event -> Text
forall a. Show a => a -> Text
showT Event
ev
    Just Event
e -> [Event] -> IO ()
ch [Event
e]
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

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