yi-0.8.2: src/library/Yi/UI/Pango/Control.hs
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, MultiParamTypeClasses
, DeriveDataTypeable, OverloadedStrings
, GeneralizedNewtypeDeriving, FlexibleContexts #-}
-- this module isn't finished, and there's heaps of warnings.
{-# OPTIONS_GHC -w #-}
-- |
-- Module : Yi.UI.Pango.Control
-- Copyright : 2007-2009 Jean-Philippe Bernardy, Hamish Mackenzie
-- License : GPL
module Yi.UI.Pango.Control (
Control(..)
, ControlM(..)
, Buffer(..)
, View(..)
, Iter(..)
, startControl
, runControl
, controlIO
, liftYi
, getControl
, newBuffer
, newView
, getBuffer
, setBufferMode
, withBuffer
, setText
, getText
, keyTable
) where
import Data.Text (unpack, pack, Text)
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 Control.Lens hiding (views, Action)
import Data.Foldable
import Data.Maybe (maybe, fromJust, fromMaybe)
import Data.IORef
import Data.List (nub, filter, drop, zip, take, length)
import Data.Prototype
import qualified Data.Rope as Rope
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 hiding(withBuffer)
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 (liftM, 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
import System.FilePath
import qualified Yi.UI.Common as Common
data Control = Control
{ controlYi :: Yi
, tabCache :: IORef [TabInfo]
, views :: IORef (Map.Map WindowRef View)
}
-- { config :: Config
-- , editor :: Editor
-- , input :: Event -> IO ()
-- , output :: Action -> IO ()
-- }
data TabInfo = TabInfo
{ coreTab :: Tab
-- , page :: VBox
}
instance Show TabInfo where
show t = show (coreTab t)
--type ControlM = YiM
newtype ControlM a = ControlM { runControl'' :: ReaderT Control IO a }
deriving (Monad, MonadBase IO, MonadReader Control, Typeable,
Functor, Applicative)
-- Helper functions to avoid issues with mismatching monad libraries
controlIO :: IO a -> ControlM a
controlIO = liftBase
getControl :: ControlM Control
getControl = ask
liftYi :: YiM a -> ControlM a
liftYi m = do
yi <- asks controlYi
liftBase $ runReaderT (runYiM m) yi
--instance MonadState Editor ControlM where
-- get = readRef =<< editor <$> ask
-- put v = flip modifyRef (const v) =<< editor <$> ask
--instance MonadEditor ControlM where
-- askCfg = config <$> ask
-- withEditor f = do
-- r <- asks editor
-- cfg <- asks config
-- liftBase $ controlUnsafeWithEditor cfg r f
startControl :: Config -> ControlM () -> IO ()
startControl config main = startEditor (config { startFrontEnd = start main } ) Nothing
runControl' :: ControlM a -> MVar Control -> IO (Maybe a)
runControl' m yiMVar = do
empty <- isEmptyMVar yiMVar
if empty
then return Nothing
else do
yi <- readMVar yiMVar
result <- runControl m yi
return $ Just result
-- runControl :: ControlM a -> Yi -> IO a
-- runControl m yi = runReaderT (runYiM m) yi
runControl :: ControlM a -> Control -> IO a
runControl f = runReaderT (runControl'' f)
-- runControlEditor f yiMVar = yiMVar
runAction :: Action -> ControlM ()
runAction action = do
out <- liftYi $ asks output
liftBase $ out [action]
-- | Test 2
mkUI :: IO () -> MVar Control -> Common.UI
mkUI main yiMVar = Common.dummyUI
{ Common.main = main
, Common.end = \_ -> void $ runControl' end yiMVar
, Common.suspend = void $ runControl' suspend yiMVar
, Common.refresh = \e -> void $ runControl' (refresh e) yiMVar
, Common.layout = \e -> liftM (fromMaybe e) $
runControl' (doLayout e) yiMVar
, Common.reloadProject = \f -> void $ runControl' (reloadProject f) yiMVar
}
start :: ControlM () -> UIBoot
start main cfg ch outCh ed =
catch (startNoMsg main cfg ch outCh ed) (\(GError _dom _code msg) ->
fail $ unpack msg)
makeControl :: MVar Control -> YiM ()
makeControl controlMVar = do
controlYi <- ask
tabCache <- liftBase $ newIORef []
views <- liftBase $ newIORef Map.empty
liftBase $ putMVar controlMVar Control{..}
startNoMsg :: ControlM () -> UIBoot
startNoMsg main config input output ed = do
control <- newEmptyMVar
let wrappedMain = do
output [makeAction $ makeControl control]
void (runControl' main control)
return (mkUI wrappedMain control)
end :: ControlM ()
end = do
liftBase $ putStrLn "Yi Control End"
liftBase mainQuit
suspend :: ControlM ()
suspend = do
liftBase $ putStrLn "Yi Control Suspend"
return ()
{-# ANN refresh ("HLint: ignore Redundant do" :: String) #-}
refresh :: Editor -> ControlM ()
refresh e = do
--contextId <- statusbarGetContextId (uiStatusbar ui) "global"
--statusbarPop (uiStatusbar ui) contextId
--statusbarPush (uiStatusbar ui) contextId $ intercalate " " $ statusLine e
updateCache e -- The cursor may have changed since doLayout
viewsRef <- asks views
vs <- liftBase $ readRef viewsRef
forM_ (Map.elems vs) $ \v -> do
let b = findBufferWith (viewFBufRef v) e
-- when (not $ null $ b ^. pendingUpdatesA) $
do
-- sig <- readIORef (renderer w)
-- signalDisconnect sig
-- writeRef (renderer w)
-- =<< (textview w `onExpose` render e ui b (wkey (coreWin w)))
liftBase $ widgetQueueDraw (drawArea v)
doLayout :: Editor -> ControlM Editor
doLayout e = do
liftBase $ putStrLn "Yi Control Do Layout"
updateCache e
cacheRef <- asks tabCache
tabs <- liftBase $ readRef cacheRef
heights <- concat <$> mapM (getHeightsInTab e) tabs
let e' = (tabsA %~ fmap (mapWindows updateWin)) e
updateWin w = case find (\(ref,_,_) -> (wkey w == ref)) heights of
Nothing -> w
Just (_,h,rgn) -> w { height = h, winRegion = rgn }
-- Don't leak references to old Windows
let forceWin x w = height w `seq` winRegion w `seq` x
return $ (foldl . tabFoldl) forceWin e' (e' ^. tabsA)
getHeightsInTab :: Editor -> TabInfo -> ControlM [(WindowRef,Int,Region)]
getHeightsInTab e tab = do
viewsRef <- asks views
vs <- liftBase $ readRef viewsRef
foldlM (\a w ->
case Map.lookup (wkey w) vs of
Just v -> do
(_, h) <- liftBase $ widgetGetSize $ drawArea v
let lineHeight = ascent (metrics v) + descent (metrics v)
let b0 = findBufferWith (viewFBufRef v) e
rgn <- shownRegion e v b0
let ret= (windowRef v, round $ fromIntegral h / lineHeight, rgn)
return $ a ++ [ret]
Nothing -> return a)
[] (coreTab tab ^. tabWindowsA)
shownRegion :: Editor -> View -> FBuffer -> ControlM Region
shownRegion e v b = do
(tos, _, bos) <- updatePango e v b (layout v)
return $ mkRegion tos bos
updatePango :: Editor -> View -> FBuffer -> PangoLayout
-> ControlM (Point, Point, Point)
updatePango e v b layout = do
(width', height') <- liftBase $ widgetGetSize $ drawArea v
font <- liftBase $ layoutGetFontDescription layout
--oldFont <- layoutGetFontDescription layout
--oldFontStr <- maybe (return Nothing)
-- (fmap Just . fontDescriptionToString) oldFont
--newFontStr <- Just <$> fontDescriptionToString font
--when (oldFontStr /= newFontStr)
-- (layoutSetFontDescription layout (Just font))
let win = findWindowWith (windowRef v) e
[width'', height''] = map fromIntegral [width', height']
lineHeight = ascent (metrics v) + descent (metrics v)
winh = max 1 $ floor (height'' / lineHeight)
(tos, point, text) = askBuffer win b $ do
from <- getMarkPointB =<< fromMark <$> askMarks
rope <- streamB Forward from
p <- pointB
let content = fst $ Rope.splitAtLine winh rope
-- allow BOS offset to be just after the last line
let addNL = if Rope.countNewLines content == winh
then id
else (++"\n")
return (from, p, addNL $ Rope.toString content)
config <- liftYi askCfg
if configLineWrap $ configUI config
then do oldWidth <- liftBase $ layoutGetWidth layout
when (oldWidth /= Just width'') $
liftBase $ layoutSetWidth layout $ Just width''
else do
(Rectangle px _py pwidth _pheight, _) <- liftBase $
layoutGetPixelExtents layout
liftBase $ widgetSetSizeRequest (drawArea v) (px+pwidth) (-1)
-- optimize for cursor movement
oldText <- liftBase $ layoutGetText layout
when (oldText /= text) $ liftBase $ layoutSetText layout text
(_, bosOffset, _) <- liftBase $ layoutXYToIndex layout width''
(fromIntegral winh * lineHeight - 1)
return (tos, point, tos + fromIntegral bosOffset + 1)
updateCache :: Editor -> ControlM ()
updateCache e = do
let tabs = e ^. tabsA
cacheRef <- asks tabCache
cache <- liftBase $ readRef cacheRef
cache' <- syncTabs e (toList $ PL.withFocus tabs) cache
liftBase $ writeRef cacheRef cache'
syncTabs :: Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs e (tfocused@(t,focused):ts) (c:cs)
| t == coreTab c =
do when focused $ setTabFocus c
-- let vCache = views c
(:) <$> syncTab e c t <*> syncTabs e ts cs
| t `elem` map coreTab cs =
do removeTab c
syncTabs e (tfocused:ts) cs
| otherwise =
do c' <- insertTabBefore e t c
when focused $ setTabFocus c'
return (c':) `ap` syncTabs e ts (c:cs)
syncTabs e ts [] = mapM (\(t,focused) -> do
c' <- insertTab e t
when focused $ setTabFocus c'
return c') ts
syncTabs _ [] cs = mapM_ removeTab cs >> return []
syncTab :: Editor -> TabInfo -> Tab -> ControlM TabInfo
syncTab e tab ws =
-- TODO Maybe do something here
return tab
setTabFocus :: TabInfo -> ControlM ()
setTabFocus t =
-- TODO this needs to set the tab focus with callback
-- but only if the tab focus has changed
return ()
askBuffer :: Yi.Window -> FBuffer -> BufferM a -> a
askBuffer w b f = fst $ runBuffer w b f
setWindowFocus :: Editor -> TabInfo -> View -> ControlM ()
setWindowFocus e t v = do
let bufferName = shortIdentString (commonNamePrefix e) $
findBufferWith (viewFBufRef v) e
window = findWindowWith (windowRef v) e
ml = askBuffer window (findBufferWith (viewFBufRef v) e) $
getModeLine (commonNamePrefix e)
-- TODO
-- update (textview w) widgetIsFocus True
-- update (modeline w) labelText ml
-- update (uiWindow ui) windowTitle $ bufferName ++ " - Yi"
-- update (uiNotebook ui) (notebookChildTabLabel (page t))
-- (tabAbbrevTitle bufferName)
return ()
removeTab :: TabInfo -> ControlM ()
removeTab t =
-- TODO this needs to close the views in the tab with callback
return ()
removeView :: TabInfo -> View -> ControlM ()
removeView tab view =
-- TODO this needs to close the view with callback
return ()
-- | Make a new tab.
newTab :: Editor -> Tab -> ControlM TabInfo
newTab e ws = do
let t' = TabInfo { coreTab = ws }
-- cache <- syncWindows e t' (toList $ PL.withFocus ws) []
return t' -- { views = cache }
{-# ANN insertTabBefore ("HLint: ignore Redundant do" :: String) #-}
insertTabBefore :: Editor -> Tab -> TabInfo -> ControlM TabInfo
insertTabBefore e ws c = do
-- Just p <- notebookPageNum (uiNotebook ui) (page c)
-- vb <- vBoxNew False 1
-- notebookInsertPage (uiNotebook ui) vb "" p
-- widgetShowAll $ vb
newTab e ws
{-# ANN insertTab ("HLint: ignore Redundant do" :: String) #-}
insertTab :: Editor -> Tab -> ControlM TabInfo
insertTab e ws = do
-- vb <- vBoxNew False 1
-- notebookAppendPage (uiNotebook ui) vb ""
-- widgetShowAll $ vb
newTab e ws
{-
insertWindowBefore :: Editor -> TabInfo -> Yi.Window -> WinInfo -> IO WinInfo
insertWindowBefore e ui tab w _c = insertWindow e ui tab w
insertWindowAtEnd :: Editor -> UI -> TabInfo -> Window -> IO WinInfo
insertWindowAtEnd e ui tab w = insertWindow e ui tab w
insertWindow :: Editor -> UI -> TabInfo -> Window -> IO WinInfo
insertWindow e ui tab win = do
let buf = findBufferWith (bufkey win) e
liftBase $ do w <- newWindow e ui win buf
set (page tab) $
[ containerChild := widget w
, boxChildPacking (widget w) :=
if isMini (coreWin w)
then PackNatural
else PackGrow
]
let ref = (wkey . coreWin) w
textview w `onButtonRelease` handleClick ui ref
textview w `onButtonPress` handleClick ui ref
textview w `onScroll` handleScroll ui ref
textview w `onConfigure` handleConfigure ui ref
widgetShowAll (widget w)
return w
-}
reloadProject :: FilePath -> ControlM ()
reloadProject _ = return ()
controlUnsafeWithEditor :: Config -> MVar Editor -> EditorM a -> IO a
controlUnsafeWithEditor cfg r f = modifyMVar r $ \e -> do
let (e',a) = runEditor cfg f e
-- Make sure that the result of runEditor is evaluated before
-- replacing the editor state. Otherwise, we might replace e
-- with an exception-producing thunk, which makes it impossible
-- to look at or update the editor state.
-- Maybe this could also be fixed by -fno-state-hack flag?
-- TODO: can we simplify this?
e' `seq` a `seq` return (e', a)
data Buffer = Buffer
{ fBufRef :: BufferRef
}
data View = View
{ viewFBufRef :: BufferRef
, windowRef :: WindowRef
, drawArea :: DrawingArea
, layout :: PangoLayout
, language :: Language
, metrics :: FontMetrics
, scrollWin :: ScrolledWindow
, shownTos :: IORef Point
, winMotionSignal :: IORef (Maybe (ConnectId DrawingArea))
}
data Iter = Iter
{ iterFBufRef :: BufferRef
, point :: Point
}
newBuffer :: BufferId -> String -> ControlM Buffer
newBuffer id text = do
fBufRef <- liftYi $ withEditor $ newBufferE id $ Rope.fromString text
return Buffer{..}
newView :: Buffer -> FontDescription -> ControlM View
newView buffer font = do
control <- ask
config <- liftYi askCfg
let viewFBufRef = fBufRef buffer
newWindow <-
fmap (\w -> w { height=50
, winRegion = mkRegion (Point 0) (Point 2000)
}) $ liftYi $ withEditor $ newWindowE False viewFBufRef
let windowRef = wkey newWindow
liftYi $ withEditor $ do
(%=) windowsA (PL.insertRight newWindow)
e <- get
put $ focusAllSyntax e
drawArea <- liftBase drawingAreaNew
liftBase . widgetModifyBg drawArea StateNormal . mkCol False
. Yi.Style.background . baseAttributes . configStyle $ configUI config
context <- liftBase $ widgetCreatePangoContext drawArea
layout <- liftBase $ layoutEmpty context
liftBase $ layoutSetFontDescription layout (Just font)
language <- liftBase $ contextGetLanguage context
metrics <- liftBase $ contextGetMetrics context font language
liftBase $ layoutSetText layout ("" :: Text)
scrollWin <- liftBase $ scrolledWindowNew Nothing Nothing
liftBase $ do
scrolledWindowAddWithViewport scrollWin drawArea
scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyNever
initialTos <-
liftYi . withEditor . withGivenBufferAndWindow0 newWindow viewFBufRef $
getMarkPointB =<< fromMark <$> askMarks
shownTos <- liftBase $ newIORef initialTos
winMotionSignal <- liftBase $ newIORef Nothing
let view = View {..}
liftBase $ Gtk.widgetAddEvents drawArea [KeyPressMask]
liftBase $ Gtk.set drawArea [Gtk.widgetCanFocus := True]
liftBase $ drawArea `Gtk.onKeyPress` \event -> do
putStrLn $ "Yi Control Key Press = " ++ show event
runControl (runAction $ makeAction $ do
focusWindowE windowRef
switchToBufferE viewFBufRef) control
result <- processEvent (input $ controlYi control) event
widgetQueueDraw drawArea
return result
liftBase $ drawArea `Gtk.onButtonPress` \event -> do
widgetGrabFocus drawArea
runControl (handleClick view event) control
liftBase $ drawArea `Gtk.onButtonRelease` \event ->
runControl (handleClick view event) control
liftBase $ drawArea `Gtk.onScroll` \event ->
runControl (handleScroll view event) control
liftBase $ drawArea `Gtk.onExpose` \event -> do
(text, allAttrs, debug, tos, rel, point, inserting) <-
runControl (liftYi $ withEditor $ do
window <- findWindowWith windowRef <$> get
(%=) buffersA (fmap (clearSyntax . clearHighlight))
let winh = height window
let tos = max 0 (regionStart (winRegion window))
let bos = regionEnd (winRegion window)
let rel p = fromIntegral (p - tos)
withGivenBufferAndWindow0 window viewFBufRef $ do
-- tos <- getMarkPointB =<< fromMark <$> askMarks
rope <- streamB Forward tos
point <- pointB
inserting <- use insertingA
modeNm <- gets (withMode0 modeName)
-- let (tos, point, text, picture) = do runBu
-- from <- getMarkPointB =<< fromMark <$> askMarks
-- rope <- streamB Forward from
-- p <- pointB
let content = fst $ Rope.splitAtLine winh rope
-- allow BOS offset to be just after the last line
let addNL = if Rope.countNewLines content == winh
then id
else (++"\n")
sty = extractValue $ configTheme (configUI config)
-- attributesPictureAndSelB sty (currentRegex e)
-- (mkRegion tos bos)
-- return (from, p, addNL $ Rope.toString content,
-- picture)
let text = addNL $ Rope.toString content
picture <- attributesPictureAndSelB sty Nothing
(mkRegion tos bos)
-- add color attributes.
let picZip = zip picture $ drop 1 (fst <$> picture) ++ [bos]
strokes = [ (start',s,end') | ((start', s), end') <- picZip
, s /= emptyAttributes ]
rel p = fromIntegral (p - tos)
allAttrs = concat $ do
(p1, Attributes fg bg _rv bd itlc udrl, p2) <- strokes
let atr x = x (rel p1) (rel p2)
if' p x y = if p then x else y
return [ atr AttrForeground $ mkCol True fg
, atr AttrBackground $ mkCol False bg
, atr AttrStyle $ if' itlc StyleItalic StyleNormal
, atr AttrUnderline $
if' udrl UnderlineSingle UnderlineNone
, atr AttrWeight $ if' bd WeightBold WeightNormal
]
return (text, allAttrs, (picture, strokes, modeNm,
window, tos, bos, winh),
tos, rel, point, inserting)) control
-- putStrLn $ "Setting Layout Attributes " ++ show debug
layoutSetAttributes layout allAttrs
-- putStrLn "Done Stting Layout Attributes"
dw <- widgetGetDrawWindow drawArea
gc <- gcNew dw
oldText <- layoutGetText layout
when (text /= oldText) $ layoutSetText layout text
drawLayout dw gc 0 0 layout
liftBase $ writeRef shownTos tos
-- paint the cursor
(PangoRectangle curx cury curw curh, _) <-
layoutGetCursorPos layout (rel point)
PangoRectangle chx chy chw chh <-
layoutIndexToPos layout (rel point)
gcSetValues gc
(newGCValues { Gtk.foreground = mkCol True . Yi.Style.foreground
. baseAttributes . configStyle $
configUI config })
if inserting
then drawLine dw gc (round curx, round cury) (round $ curx + curw, round $ cury + curh)
else drawRectangle dw gc False (round chx) (round chy) (if chw > 0 then round chw else 8) (round chh)
return True
liftBase $ widgetGrabFocus drawArea
tabsRef <- asks tabCache
ts <- liftBase $ readRef tabsRef
-- TODO: the Tab idkey should be assigned using
-- Yi.Editor.newRef. But we can't modify that here, since our
-- access to 'Yi' is readonly.
liftBase $ writeRef tabsRef (TabInfo (makeTab1 0 newWindow):ts)
viewsRef <- asks views
vs <- liftBase $ readRef viewsRef
liftBase $ writeRef viewsRef $ Map.insert windowRef view vs
return view
where
clearHighlight fb =
-- if there were updates, then hide the selection.
let h = view highlightSelectionA fb
us = view pendingUpdatesA fb
in highlightSelectionA .~ (h && null us) $ fb
{-# ANN setBufferMode ("HLint: ignore Redundant do" :: String) #-}
setBufferMode :: FilePath -> Buffer -> ControlM ()
setBufferMode f buffer = do
let bufRef = fBufRef buffer
-- adjust the mode
tbl <- liftYi $ asks (modeTable . yiConfig)
contents <- liftYi $ withEditor $ withGivenBuffer0 bufRef elemsB
let header = take 1024 contents
hmode = case header =~ ("\\-\\*\\- *([^ ]*) *\\-\\*\\-" :: String) of
AllTextSubmatches [_,m] -> m
_ -> ""
Just mode = find (\(AnyMode m)-> modeName m == hmode) tbl <|>
find (\(AnyMode m)-> modeApplies m f contents) tbl <|>
Just (AnyMode emptyMode)
case mode of
AnyMode newMode -> do
-- liftBase $ putStrLn $ show (f, modeName newMode)
liftYi $ withEditor $ do
withGivenBuffer0 bufRef $ do
setMode newMode
modify clearSyntax
switchToBufferE bufRef
-- withEditor focusAllSyntax
withBuffer :: Buffer -> BufferM a -> ControlM a
withBuffer Buffer{fBufRef = b} f = liftYi $ withEditor $ withGivenBuffer0 b f
getBuffer :: View -> Buffer
getBuffer view = Buffer {fBufRef = viewFBufRef view}
setText :: Buffer -> String -> ControlM ()
setText b text = withBuffer b $ do
r <- regionOfB Document
replaceRegionClever r text
getText :: Buffer -> Iter -> Iter -> ControlM String
getText b Iter{point = p1} Iter{point = p2} =
withBuffer b . readRegionB $ mkRegion p1 p2
mkCol :: Bool -- ^ is foreground?
-> Yi.Style.Color -> Gtk.Color
mkCol True Default = Color 0 0 0
mkCol False Default = Color maxBound maxBound maxBound
mkCol _ (RGB x y z) = Color (fromIntegral x * 256)
(fromIntegral y * 256)
(fromIntegral z * 256)
handleClick :: View -> Gdk.Events.Event -> ControlM Bool
handleClick view event = do
control <- ask
-- (_tabIdx,winIdx,w) <- getWinInfo ref <$> readIORef (tabCache ui)
logPutStrLn $ "Click: " ++ show (Gdk.Events.eventX event,
Gdk.Events.eventY event,
Gdk.Events.eventClick event)
-- retrieve the clicked offset.
(_,layoutIndex,_) <- io $ layoutXYToIndex (layout view)
(Gdk.Events.eventX event) (Gdk.Events.eventY event)
tos <- readRef (shownTos view)
let p1 = tos + fromIntegral layoutIndex
let winRef = windowRef view
-- maybe focus the window
-- logPutStrLn $ "Clicked inside window: " ++ show view
-- let focusWindow = do
-- TODO: check that tabIdx is the focus?
-- (%=) windowsA (fromJust . PL.move winIdx)
liftBase $ case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
(Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
cid <- onMotionNotify (drawArea view) False $ \event ->
runControl (handleMove view p1 event) control
writeRef (winMotionSignal view) $ Just cid
_ -> do
maybe (return ()) signalDisconnect =<< readRef (winMotionSignal view)
writeRef (winMotionSignal view) Nothing
case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
(Gdk.Events.SingleClick, Gdk.Events.LeftButton) ->
runAction . makeAction $ do
-- b <- gets $ (bkey . findBufferWith (viewFBufRef view))
-- focusWindow
window <- findWindowWith winRef <$> get
withGivenBufferAndWindow0 window (viewFBufRef view) $ do
moveTo p1
setVisibleSelection False
-- (Gdk.Events.SingleClick, _) -> runAction focusWindow
(Gdk.Events.ReleaseClick, Gdk.Events.MiddleButton) -> do
disp <- liftBase $ widgetGetDisplay (drawArea view)
cb <- liftBase $ clipboardGetForDisplay disp selectionPrimary
let cbHandler Nothing = return ()
cbHandler (Just txt) = runControl (runAction . makeAction $ do
window <- findWindowWith winRef <$> get
withGivenBufferAndWindow0 window (viewFBufRef view) $ do
pointB >>= setSelectionMarkPointB
moveTo p1
insertN txt) control
liftBase $ clipboardRequestText cb cbHandler
_ -> return ()
liftBase $ widgetQueueDraw (drawArea view)
return True
handleScroll :: View -> Gdk.Events.Event -> ControlM Bool
handleScroll view event = do
let editorAction =
withBuffer0 $ vimScrollB $ case Gdk.Events.eventDirection event of
Gdk.Events.ScrollUp -> -1
Gdk.Events.ScrollDown -> 1
_ -> 0 -- Left/right scrolling not supported
runAction $ makeAction editorAction
liftBase $ widgetQueueDraw (drawArea view)
return True
handleMove :: View -> Point -> Gdk.Events.Event -> ControlM Bool
handleMove view p0 event = do
logPutStrLn $ "Motion: " ++ show (Gdk.Events.eventX event,
Gdk.Events.eventY event)
-- retrieve the clicked offset.
(_,layoutIndex,_) <-
liftBase $ layoutXYToIndex (layout view)
(Gdk.Events.eventX event) (Gdk.Events.eventY event)
tos <- readRef (shownTos view)
let p1 = tos + fromIntegral layoutIndex
let editorAction = do
txt <- withBuffer0 $
if p0 /= p1
then Just <$> do
m <- selMark <$> askMarks
setMarkPointB m p0
moveTo p1
setVisibleSelection True
readRegionB =<< getSelectRegionB
else return Nothing
maybe (return ()) setRegE txt
runAction $ makeAction editorAction
-- drawWindowGetPointer (textview w) -- be ready for next message.
-- Relies on uiActionCh being synchronous
selection <- liftBase $ newIORef ""
let yiAction = do
txt <- withEditor (withBuffer0 (readRegionB =<< getSelectRegionB))
:: YiM String
liftBase $ writeIORef selection txt
runAction $ makeAction yiAction
txt <- liftBase $ readIORef selection
disp <- liftBase $ widgetGetDisplay (drawArea view)
cb <- liftBase $ clipboardGetForDisplay disp selectionPrimary
liftBase $ clipboardSetWithData cb [(targetString,0)]
(\0 -> void (selectionDataSetText txt)) (return ())
liftBase $ widgetQueueDraw (drawArea view)
return True
processEvent :: (Event -> IO ()) -> Gdk.Events.Event -> IO Bool
processEvent ch ev = do
-- logPutStrLn $ "Gtk.Event: " ++ show ev
-- logPutStrLn $ "Event: " ++ show (gtkToYiEvent ev)
case gtkToYiEvent ev of
Nothing -> logPutStrLn $ "Event not translatable: " ++ show ev
Just e -> ch e
return True
gtkToYiEvent :: Gdk.Events.Event -> Maybe Event
gtkToYiEvent (Gdk.Events.Key {Gdk.Events.eventKeyName = key
, Gdk.Events.eventModifier = evModifier
, Gdk.Events.eventKeyChar = char})
= fmap (\k -> Event k $ (nub $ (if isShift
then filter (/= MShift)
else id) $ concatMap modif evModifier)) key'
where (key',isShift) =
case char of
Just c -> (Just $ KASCII c, True)
Nothing -> (Map.lookup key keyTable, False)
modif Gdk.Events.Control = [MCtrl]
modif Gdk.Events.Alt = [MMeta]
modif Gdk.Events.Shift = [MShift]
modif _ = []
gtkToYiEvent _ = Nothing
-- | Map GTK long names to Keys
keyTable :: Map.Map Text Key
keyTable = Map.fromList
[("Down", KDown)
,("Up", KUp)
,("Left", KLeft)
,("Right", KRight)
,("Home", KHome)
,("End", KEnd)
,("BackSpace", KBS)
,("Delete", KDel)
,("Page_Up", KPageUp)
,("Page_Down", KPageDown)
,("Insert", KIns)
,("Escape", KEsc)
,("Return", KEnter)
,("Tab", KTab)
,("ISO_Left_Tab", KTab)
]