module Yi.Frontend.Pango (start, startGtkHook) where
import Control.Applicative
import Control.Concurrent
import Control.Exception (catch, SomeException)
import Lens.Micro.Platform hiding (set)
import Control.Monad hiding (forM_, mapM_, forM, mapM)
import Data.Foldable
import Data.IORef
import qualified Data.List.PointedList as PL (moveTo)
import qualified Data.List.PointedList.Circular as PL
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Text (unpack, Text)
import qualified Data.Text as T
import Data.Traversable
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk hiding (Region, Window, Action , Point,
Style, Modifier, on)
import qualified Graphics.UI.Gtk.Gdk.EventM as EventM
import qualified Graphics.UI.Gtk.Gdk.GC as Gtk
import Graphics.UI.Gtk.Gdk.GC hiding (foreground)
import Prelude hiding (error, elem, mapM_, foldl, concat, mapM)
import System.Glib.GError
import Yi.Buffer
import Yi.Config
import Yi.Debug
import Yi.Editor
import Yi.Event
import Yi.Keymap
import Yi.Layout(DividerPosition, DividerRef)
import Yi.Monad
import qualified Yi.Rope as R
import Yi.Style
import Yi.Tab
import Yi.Types (fontsizeVariation, attributes)
import qualified Yi.UI.Common as Common
import Yi.Frontend.Pango.Control (keyTable)
import Yi.Frontend.Pango.Layouts
import Yi.Frontend.Pango.Utils
import Yi.String (showT)
import Yi.UI.TabBar
import Yi.UI.Utils
import Yi.Utils
import Yi.Window
data UI = UI
{ uiWindow :: Gtk.Window
, uiNotebook :: SimpleNotebook
, uiStatusbar :: Statusbar
, tabCache :: IORef TabCache
, uiActionCh :: Action -> IO ()
, uiConfig :: UIConfig
, uiFont :: IORef FontDescription
, uiInput :: IMContext
}
type TabCache = PL.PointedList TabInfo
type WindowCache = M.Map WindowRef WinInfo
data TabInfo = TabInfo
{ coreTabKey :: TabRef
, layoutDisplay :: LayoutDisplay
, miniwindowPage :: MiniwindowDisplay
, tabWidget :: Widget
, windowCache :: IORef WindowCache
, fullTitle :: IORef Text
, abbrevTitle :: IORef Text
}
instance Show TabInfo where
show t = show (coreTabKey t)
data WinInfo = WinInfo
{ coreWinKey :: WindowRef
, coreWin :: IORef Window
, shownTos :: IORef Point
, lButtonPressed :: IORef Bool
, insertingMode :: IORef Bool
, inFocus :: IORef Bool
, winLayoutInfo :: MVar WinLayoutInfo
, winMetrics :: FontMetrics
, textview :: DrawingArea
, modeline :: Label
, winWidget :: Widget
}
data WinLayoutInfo = WinLayoutInfo {
winLayout :: !PangoLayout,
tos :: !Point,
bos :: !Point,
bufEnd :: !Point,
cur :: !Point,
buffer :: !FBuffer,
regex :: !(Maybe SearchExp)
}
instance Show WinInfo where
show w = show (coreWinKey w)
instance Ord EventM.Modifier where
x <= y = fromEnum x <= fromEnum y
mkUI :: UI -> Common.UI Editor
mkUI ui = Common.dummyUI
{ Common.main = main
, Common.end = const end
, Common.suspend = windowIconify (uiWindow ui)
, Common.refresh = refresh ui
, Common.layout = doLayout ui
, Common.reloadProject = const reloadProject
}
updateFont :: UIConfig -> IORef FontDescription -> IORef TabCache -> Statusbar
-> FontDescription -> IO ()
updateFont cfg fontRef tc status font = do
maybe (return ()) (fontDescriptionSetFamily font) (configFontName cfg)
writeIORef fontRef font
widgetModifyFont status (Just font)
tcs <- readIORef tc
forM_ tcs $ \tabinfo -> do
wcs <- readIORef (windowCache tabinfo)
forM_ wcs $ \wininfo -> do
withMVar (winLayoutInfo wininfo) $ \WinLayoutInfo{winLayout} ->
layoutSetFontDescription winLayout (Just font)
widgetModifyFont (textview wininfo) (Just font)
widgetModifyFont (modeline wininfo) (Just font)
askBuffer :: Window -> FBuffer -> BufferM a -> a
askBuffer w b f = fst $ runBuffer w b f
start :: UIBoot
start = startGtkHook (const $ return ())
startGtkHook :: (Gtk.Window -> IO ()) -> UIBoot
startGtkHook userHook cfg ch outCh ed =
catch (startNoMsgGtkHook userHook cfg ch outCh ed)
(\(GError _dom _code msg) -> fail $ unpack msg)
startNoMsgGtkHook :: (Gtk.Window -> IO ()) -> UIBoot
startNoMsgGtkHook userHook cfg ch outCh ed = do
logPutStrLn "startNoMsgGtkHook"
void unsafeInitGUIForThreadedRTS
win <- windowNew
ico <- loadIcon "yi+lambda-fat-32.png"
vb <- vBoxNew False 1
im <- imMulticontextNew
imContextSetUsePreedit im False
let imContextCommitS :: Signal IMContext (String -> IO ())
imContextCommitS = imContextCommit
im `on` imContextCommitS $ mapM_ (\k -> ch [Event (KASCII k) []])
set win [ windowDefaultWidth := 700
, windowDefaultHeight := 900
, windowTitle := ("Yi" :: T.Text)
, windowIcon := Just ico
, containerChild := vb
]
win `on` deleteEvent $ io $ mainQuit >> return True
win `on` keyPressEvent $ handleKeypress ch im
paned <- hPanedNew
tabs <- simpleNotebookNew
panedAdd2 paned (baseWidget tabs)
status <- statusbarNew
statusbarGetMessageArea status >>= containerGetChildren >>= \case
[w] -> labelSetSingleLineMode (castToLabel w) False
_ -> return ()
set vb [ containerChild := paned
, containerChild := status
, boxChildPacking status := PackNatural
]
fontRef <- fontDescriptionNew >>= newIORef
let actionCh = outCh . return
tc <- newIORef =<< newCache ed actionCh
let watchFont = (fontDescriptionFromString ("Monospace 10" :: T.Text) >>=)
watchFont $ updateFont (configUI cfg) fontRef tc status
userHook win
void $ timeoutAddFull (yield >> return True) priorityDefaultIdle 50
widgetShowAll win
let ui = UI win tabs status tc actionCh (configUI cfg) fontRef im
let move n pl = fromMaybe pl (PL.moveTo n pl)
runAction = uiActionCh ui . makeAction
simpleNotebookOnSwitchPage (uiNotebook ui) $ \n -> postGUIAsync $
runAction ((%=) tabsA (move n) :: EditorM ())
return (mkUI ui)
main :: IO ()
main = logPutStrLn "GTK main loop running" >> mainGUI
end :: IO ()
end = mainQuit
updateCache :: UI -> Editor -> IO ()
updateCache ui e = do
cache <- readIORef $ tabCache ui
let cacheMap = mapFromFoldable . fmap (\t -> (coreTabKey t, t)) $ cache
cache' <- forM (e ^. tabsA) $ \tab ->
case M.lookup (tkey tab) cacheMap of
Just t -> updateTabInfo e ui tab t >> return t
Nothing -> newTab e ui tab
writeIORef (tabCache ui) cache'
simpleNotebookSet (uiNotebook ui)
=<< forM cache' (\t -> (tabWidget t,) <$> readIORef (abbrevTitle t))
updateTabInfo :: Editor -> UI -> Tab -> TabInfo -> IO ()
updateTabInfo e ui tab tabInfo = do
wCacheOld <- readIORef (windowCache tabInfo)
wCacheNew <- mapFromFoldable <$> forM (tab ^. tabWindowsA) (\w ->
case M.lookup (wkey w) wCacheOld of
Just wInfo -> updateWindow e ui w wInfo >> return (wkey w, wInfo)
Nothing -> (wkey w,) <$> newWindow e ui w)
writeIORef (windowCache tabInfo) wCacheNew
let lookupWin w = wCacheNew M.! w
layoutDisplaySet (layoutDisplay tabInfo)
. fmap (winWidget . lookupWin) . tabLayout $ tab
miniwindowDisplaySet (miniwindowPage tabInfo)
. fmap (winWidget . lookupWin . wkey) . tabMiniWindows $ tab
setWindowFocus e ui tabInfo . lookupWin . wkey . tabFocus $ tab
updateWindow :: Editor -> UI -> Window -> WinInfo -> IO ()
updateWindow e _ui win wInfo = do
writeIORef (inFocus wInfo) False
writeIORef (coreWin wInfo) win
writeIORef (insertingMode wInfo)
(askBuffer win (findBufferWith (bufkey win) e) $ use insertingA)
setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()
setWindowFocus e ui t w = do
win <- readIORef (coreWin w)
let bufferName = shortIdentString (length $ commonNamePrefix e) $
findBufferWith (bufkey win) e
ml = askBuffer win (findBufferWith (bufkey win) e) $
getModeLine (T.pack <$> commonNamePrefix e)
im = uiInput ui
writeIORef (inFocus w) True
update (textview w) widgetIsFocus True
update (modeline w) labelText ml
writeIORef (fullTitle t) bufferName
writeIORef (abbrevTitle t) (tabAbbrevTitle bufferName)
drawW <- catch (fmap Just $ widgetGetDrawWindow $ textview w)
(\(_ :: SomeException) -> return Nothing)
imContextSetClientWindow im drawW
imContextFocusIn im
getWinInfo :: UI -> WindowRef -> IO WinInfo
getWinInfo ui ref =
let tabLoop [] = error "Yi.UI.Pango.getWinInfo: window not found"
tabLoop (t:ts) = do
wCache <- readIORef (windowCache t)
case M.lookup ref wCache of
Just w -> return w
Nothing -> tabLoop ts
in readIORef (tabCache ui) >>= (tabLoop . toList)
newCache :: Editor -> (Action -> IO ()) -> IO TabCache
newCache e actionCh = mapM (mkDummyTab actionCh) (e ^. tabsA)
newTab :: Editor -> UI -> Tab -> IO TabInfo
newTab e ui tab = do
t <- mkDummyTab (uiActionCh ui) tab
updateTabInfo e ui tab t
return t
mkDummyTab :: (Action -> IO ()) -> Tab -> IO TabInfo
mkDummyTab actionCh tab = do
ws <- newIORef M.empty
ld <- layoutDisplayNew
layoutDisplayOnDividerMove ld (handleDividerMove actionCh)
mwp <- miniwindowDisplayNew
tw <- vBoxNew False 0
set tw [containerChild := baseWidget ld,
containerChild := baseWidget mwp,
boxChildPacking (baseWidget ld) := PackGrow,
boxChildPacking (baseWidget mwp) := PackNatural]
ftRef <- newIORef ""
atRef <- newIORef ""
return (TabInfo (tkey tab) ld mwp (toWidget tw) ws ftRef atRef)
newWindow :: Editor -> UI -> Window -> IO WinInfo
newWindow e ui w = do
let b = findBufferWith (bufkey w) e
f <- readIORef (uiFont ui)
ml <- labelNew (Nothing :: Maybe Text)
widgetModifyFont ml (Just f)
set ml [ miscXalign := 0.01 ]
widgetSetSizeRequest ml 0 (1)
v <- drawingAreaNew
widgetModifyFont v (Just f)
widgetAddEvents v [Button1MotionMask]
widgetModifyBg v StateNormal . mkCol False . Yi.Style.background
. baseAttributes . configStyle $ uiConfig ui
sw <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport sw v
scrolledWindowSetPolicy sw PolicyAutomatic PolicyNever
box <- if isMini w
then do
prompt <- labelNew (Just $ miniIdentString b)
widgetModifyFont prompt (Just f)
hb <- hBoxNew False 1
set hb [ containerChild := prompt,
containerChild := sw,
boxChildPacking prompt := PackNatural,
boxChildPacking sw := PackGrow]
return (castToBox hb)
else do
vb <- vBoxNew False 1
set vb [ containerChild := sw,
containerChild := ml,
boxChildPacking ml := PackNatural]
return (castToBox vb)
tosRef <- newIORef (askBuffer w b (use . markPointA
=<< fromMark <$> askMarks))
context <- widgetCreatePangoContext v
layout <- layoutEmpty context
layoutRef <- newMVar (WinLayoutInfo layout 0 0 0 0
(findBufferWith (bufkey w) e) Nothing)
language <- contextGetLanguage context
metrics <- contextGetMetrics context f language
ifLButton <- newIORef False
imode <- newIORef False
focused <- newIORef False
winRef <- newIORef w
layoutSetFontDescription layout (Just f)
layoutSetText layout T.empty
let ref = wkey w
win = WinInfo { coreWinKey = ref
, coreWin = winRef
, winLayoutInfo = layoutRef
, winMetrics = metrics
, textview = v
, modeline = ml
, winWidget = toWidget box
, shownTos = tosRef
, lButtonPressed = ifLButton
, insertingMode = imode
, inFocus = focused
}
updateWindow e ui w win
v `on` buttonPressEvent $ handleButtonClick ui ref
v `on` buttonReleaseEvent $ handleButtonRelease ui win
v `on` scrollEvent $ handleScroll ui win
v `on` configureEvent $ handleConfigure ui
v `on` motionNotifyEvent $ handleMove ui win
void $ v `onExpose` render ui win
uiWindow ui `on` focusInEvent $ io (widgetQueueDraw v) >> return False
uiWindow ui `on` focusOutEvent $ io (widgetQueueDraw v) >> return False
return win
refresh :: UI -> Editor -> IO ()
refresh ui e = do
postGUIAsync $ do
contextId <- statusbarGetContextId (uiStatusbar ui) ("global" :: T.Text)
statusbarPop (uiStatusbar ui) contextId
void $ statusbarPush (uiStatusbar ui) contextId $ T.intercalate " " $
statusLine e
updateCache ui e
cache <- readIORef $ tabCache ui
forM_ cache $ \t -> do
wCache <- readIORef (windowCache t)
forM_ wCache $ \w -> do
updateWinInfoForRendering e ui w
widgetQueueDraw (textview w)
updateWinInfoForRendering :: Editor -> UI -> WinInfo -> IO ()
updateWinInfoForRendering e _ui w = modifyMVar_ (winLayoutInfo w) $ \wli -> do
win <- readIORef (coreWin w)
return $! wli{buffer=findBufferWith (bufkey win) e,regex=currentRegex e}
render :: UI -> WinInfo -> t -> IO Bool
render ui w _event =
withMVar (winLayoutInfo w) $
\WinLayoutInfo{winLayout=layout,tos,bos,cur,buffer=b,regex} -> do
win <- readIORef (coreWin w)
let picture = askBuffer win b $ attributesPictureAndSelB sty regex
(mkRegion tos bos)
sty = configStyle $ uiConfig ui
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
]
layoutSetAttributes layout allAttrs
drawWindow <- widgetGetDrawWindow $ textview w
gc <- gcNew drawWindow
drawLayout drawWindow gc 1 0 layout
im <- readIORef (insertingMode w)
bufferFocused <- readIORef (inFocus w)
uiFocused <- Gtk.windowHasToplevelFocus (uiWindow ui)
let focused = bufferFocused && uiFocused
wideCursor =
case configCursorStyle (uiConfig ui) of
AlwaysFat -> True
NeverFat -> False
FatWhenFocused -> focused
FatWhenFocusedAndInserting -> focused && im
(PangoRectangle (succ -> curX) curY curW curH, _) <-
layoutGetCursorPos layout (rel cur)
imContextSetCursorLocation (uiInput ui) $
Rectangle (round curX) (round curY) (round curW) (round curH)
gcSetValues gc
(newGCValues { Gtk.foreground = mkCol True . Yi.Style.foreground
. baseAttributes . configStyle $
uiConfig ui
, Gtk.lineWidth = if wideCursor then 2 else 1 })
if im
then
drawLine drawWindow gc (round curX, round curY)
(round $ curX + curW, round $ curY + curH)
else do
PangoRectangle (succ -> chx) chy chw chh <- layoutIndexToPos
layout (rel cur)
drawRectangle drawWindow gc False (round chx) (round chy)
(if chw > 0 then round chw else 8) (round chh)
return True
doLayout :: UI -> Editor -> IO Editor
doLayout ui e = do
updateCache ui e
tabs <- readIORef $ tabCache ui
f <- readIORef (uiFont ui)
dims <- fold <$> mapM (getDimensionsInTab ui f e) tabs
let e' = (tabsA %~ fmap (mapWindows updateWin)) e
updateWin w = case M.lookup (wkey w) dims of
Nothing -> w
Just (wi,h,rgn) -> w { width = wi, height = h, winRegion = rgn }
let forceWin x w = height w `seq` winRegion w `seq` x
return $ (foldl . tabFoldl) forceWin e' (e' ^. tabsA)
getDimensionsInTab :: UI -> FontDescription -> Editor
-> TabInfo -> IO (M.Map WindowRef (Int,Int,Region))
getDimensionsInTab ui f e tab = do
wCache <- readIORef (windowCache tab)
forM wCache $ \wi -> do
(wid, h) <- widgetGetSize $ textview wi
win <- readIORef (coreWin wi)
let metrics = winMetrics wi
lineHeight = ascent metrics + descent metrics
charWidth = max (approximateCharWidth metrics) (approximateDigitWidth metrics)
width = round $ fromIntegral wid / charWidth 1
height = round $ fromIntegral h / lineHeight
b0 = findBufferWith (bufkey win) e
rgn <- shownRegion ui f wi b0
return (width, height, rgn)
shownRegion :: UI -> FontDescription -> WinInfo -> FBuffer -> IO Region
shownRegion ui f w b = modifyMVar (winLayoutInfo w) $ \wli -> do
(tos, cur, bos, bufEnd) <- updatePango ui f w b (winLayout wli)
return (wli{tos,cur=clampTo tos bos cur,bos,bufEnd}, mkRegion tos bos)
where clampTo lo hi x = max lo (min hi x)
updatePango :: UI -> FontDescription -> WinInfo -> FBuffer
-> PangoLayout -> IO (Point, Point, Point, Point)
updatePango ui font w b layout = do
(width_', height') <- widgetGetSize $ textview w
let width' = max 0 (width_' 1)
fontDescriptionToStringT :: FontDescription -> IO Text
fontDescriptionToStringT = fontDescriptionToString
curFont <- case fromIntegral <$> configFontSize (uiConfig ui) of
Nothing -> return font
Just defSize -> fontDescriptionGetSize font >>= \case
Nothing -> fontDescriptionSetSize font defSize >> return font
Just currentSize -> let fsv = fontsizeVariation $ attributes b
newSize = max 1 (fromIntegral fsv + defSize) in
if newSize == currentSize
then return font
else do
nf <- fontDescriptionCopy font
fontDescriptionSetSize nf newSize
return nf
oldFont <- layoutGetFontDescription layout
oldFontStr <- maybe (return Nothing)
(fmap Just . fontDescriptionToStringT) oldFont
newFontStr <- Just <$> fontDescriptionToStringT curFont
when (oldFontStr /= newFontStr) $
layoutSetFontDescription layout (Just curFont)
win <- readIORef (coreWin w)
let [width'', height''] = fmap fromIntegral [width', height']
metrics = winMetrics w
lineHeight = ascent metrics + descent metrics
charWidth = max (approximateCharWidth metrics)
(approximateDigitWidth metrics)
winw = max 1 $ floor (width'' / charWidth)
winh = max 1 $ floor (height'' / lineHeight)
maxChars = winw * winh
conf = uiConfig ui
(tos, size, point, text) = askBuffer win b $ do
from <- use . markPointA =<< fromMark <$> askMarks
rope <- streamB Forward from
p <- pointB
bufEnd <- sizeB
let content = takeContent conf maxChars . fst $ R.splitAtLine winh rope
let addNL = if R.countNewLines content == winh
then id
else (`R.snoc` '\n')
return (from, bufEnd, p, R.toText $ addNL content)
if configLineWrap conf
then wrapToWidth layout WrapAnywhere width''
else do
(Rectangle px _py pwidth _pheight, _) <- layoutGetPixelExtents layout
widgetSetSizeRequest (textview w) (px+pwidth) (1)
oldText <- layoutGetText layout
when (oldText /= text) (layoutSetText layout text)
(_, bosOffset, _) <- layoutXYToIndex layout width''
(fromIntegral winh * lineHeight 1)
return (tos, point, tos + fromIntegral bosOffset + 1, size)
takeContent :: UIConfig -> Int -> R.YiString -> R.YiString
takeContent cf cl t = if configLineWrap cf
then R.take cl t
else t
wrapToWidth :: PangoLayout -> LayoutWrapMode -> Double -> IO ()
wrapToWidth l wm w = do
layoutGetWrap l >>= \wr -> case (wr, wm) of
(WrapWholeWords, WrapWholeWords) -> return ()
(WrapAnywhere, WrapAnywhere) -> return ()
(WrapPartialWords, WrapPartialWords) -> return ()
_ -> layoutSetWrap l wm
layoutGetWidth l >>= \case
Just x | x == w -> return ()
_ -> layoutSetWidth l (Just w)
reloadProject :: IO ()
reloadProject = return ()
mkCol :: Bool
-> 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)
handleKeypress :: ([Event] -> IO ())
-> IMContext
-> EventM EKey Bool
handleKeypress ch im = do
gtkMods <- eventModifier
gtkKey <- eventKeyVal
ifIM <- imContextFilterKeypress im
let char = keyToChar gtkKey
modsWithShift = M.keys $ M.filter (`elem` gtkMods) modTable
mods | isJust char = filter (/= MShift) modsWithShift
| otherwise = modsWithShift
key = case char of
Just c -> Just $ KASCII c
Nothing -> M.lookup (keyName gtkKey) keyTable
case (ifIM, key) of
(True, _ ) -> return ()
(_, Nothing) -> logPutStrLn $ "Event not translatable: " <> showT key
(_, Just k ) -> io $ ch [Event k mods]
return True
modTable :: M.Map Modifier EventM.Modifier
modTable = M.fromList
[ (MShift, EventM.Shift )
, (MCtrl, EventM.Control)
, (MMeta, EventM.Alt )
, (MSuper, EventM.Super )
, (MHyper, EventM.Hyper )
]
on :: object -> Signal object callback -> callback -> IO ()
on widget signal handler = void $ Gtk.on widget signal handler
handleButtonClick :: UI -> WindowRef -> EventM EButton Bool
handleButtonClick ui ref = do
(x, y) <- eventCoordinates
click <- eventClick
button <- eventButton
io $ do
w <- getWinInfo ui ref
point <- pointToOffset (x, y) w
let focusWindow = focusWindowE ref
runAction = uiActionCh ui . makeAction
runAction focusWindow
win <- io $ readIORef (coreWin w)
let selectRegion tu = runAction $ do
b <- gets $ bkey . findBufferWith (bufkey win)
withGivenBufferAndWindow win b $
moveTo point >> regionOfB tu >>= setSelectRegionB
case (click, button) of
(SingleClick, LeftButton) -> do
io $ writeIORef (lButtonPressed w) True
runAction $ do
b <- gets $ bkey . findBufferWith (bufkey win)
withGivenBufferAndWindow win b $ do
m <- selMark <$> askMarks
markPointA m .= point
moveTo point
setVisibleSelection False
(DoubleClick, LeftButton) -> selectRegion unitWord
(TripleClick, LeftButton) -> selectRegion Line
_ -> return ()
return True
handleButtonRelease :: UI -> WinInfo -> EventM EButton Bool
handleButtonRelease ui w = do
(x, y) <- eventCoordinates
button <- eventButton
io $ do
point <- pointToOffset (x, y) w
disp <- widgetGetDisplay $ textview w
cb <- clipboardGetForDisplay disp selectionPrimary
case button of
MiddleButton -> pasteSelectionClipboard ui w point cb
LeftButton -> setSelectionClipboard ui w cb >>
writeIORef (lButtonPressed w) False
_ -> return ()
return True
handleScroll :: UI -> WinInfo -> EventM EScroll Bool
handleScroll ui w = do
scrollDirection <- eventScrollDirection
xy <- eventCoordinates
io $ do
ifPressed <- readIORef $ lButtonPressed w
let editorAction =
withCurrentBuffer $ scrollB $ case scrollDirection of
ScrollUp -> negate configAmount
ScrollDown -> configAmount
_ -> 0
configAmount = configScrollWheelAmount $ uiConfig ui
uiActionCh ui (EditorA editorAction)
when ifPressed $ selectArea ui w xy
return True
handleConfigure :: UI -> EventM EConfigure Bool
handleConfigure ui = do
io $ postGUIAsync $ uiActionCh ui (makeAction (return () :: EditorM()))
return False
handleMove :: UI -> WinInfo -> EventM EMotion Bool
handleMove ui w = eventCoordinates >>= (io . selectArea ui w) >>
return True
handleDividerMove :: (Action -> IO ()) -> DividerRef -> DividerPosition -> IO ()
handleDividerMove actionCh ref pos =
actionCh (makeAction (setDividerPosE ref pos))
pointToOffset :: (Double, Double) -> WinInfo -> IO Point
pointToOffset (x,y) w =
withMVar (winLayoutInfo w) $ \WinLayoutInfo{winLayout,tos,bufEnd} -> do
im <- readIORef (insertingMode w)
(_, charOffsetX, extra) <- layoutXYToIndex winLayout (max 0 (x1)) y
return $ min bufEnd (tos + fromIntegral
(charOffsetX + if im then extra else 0))
selectArea :: UI -> WinInfo -> (Double, Double) -> IO ()
selectArea ui w (x,y) = do
p <- pointToOffset (x,y) w
let editorAction = do
txt <- withCurrentBuffer $ do
moveTo p
setVisibleSelection True
readRegionB =<< getSelectRegionB
setRegE txt
uiActionCh ui (makeAction editorAction)
pasteSelectionClipboard :: UI -> WinInfo -> Point -> Clipboard -> IO ()
pasteSelectionClipboard ui w p cb = do
win <- io $ readIORef (coreWin w)
let cbHandler :: Maybe R.YiString -> IO ()
cbHandler Nothing = return ()
cbHandler (Just txt) = uiActionCh ui $ EditorA $ do
b <- gets $ bkey . findBufferWith (bufkey win)
withGivenBufferAndWindow win b $ do
pointB >>= setSelectionMarkPointB
moveTo p
insertN txt
clipboardRequestText cb (cbHandler . fmap R.fromText)
setSelectionClipboard :: UI -> WinInfo -> Clipboard -> IO ()
setSelectionClipboard ui _w cb = do
selection <- newIORef mempty
let yiAction = do
txt <- withCurrentBuffer $
fmap R.toText . readRegionB =<< getSelectRegionB :: YiM T.Text
io $ writeIORef selection txt
uiActionCh ui $ makeAction yiAction
txt <- readIORef selection
unless (T.null txt) $ clipboardSetText cb txt