1 patch for repository ham...@code.haskell.org:/srv/code/yi:
Sun Apr 4 22:35:55 NZST 2010 Hamish Mackenzie
<hamish.k.macken...@googlemail.com>
* More progress on Yi.UI.Pango.Control
--
Yi development mailing list
yi-devel@googlegroups.com
http://groups.google.com/group/yi-devel
To unsubscribe, reply using "remove me" as the subject.
New patches:
[More progress on Yi.UI.Pango.Control
Hamish Mackenzie <hamish.k.macken...@googlemail.com>**20100404103555
Ignore-this: 212c8aec438a6a0742f2690242f352a4
] hunk ./src/Yi/Core.hs 43
-- * Misc
, runAction
, withSyntax
+ , focusAllSyntax
)
where
hunk ./src/Yi/UI/Pango.hs 9
-- | This module defines a user interface implemented using gtk2hs and
-- pango for direct text rendering.
-module Yi.UI.Pango (start) where
+module Yi.UI.Pango (start, processEvent) where
import Prelude (filter, map, round, FilePath, (/))
hunk ./src/Yi/UI/Pango/Control.hs 1
-{-# LANGUAGE RecordWildCards, ScopedTypeVariables, MultiParamTypeClasses, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, MultiParamTypeClasses, DeriveDataTypeable,
+ StandaloneDeriving, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
--
-- Module : Yi.UI.Pango.Control
hunk ./src/Yi/UI/Pango/Control.hs 19
, Buffer(..)
, View(..)
, Iter(..)
-, newControl
+, startControl
, runControl
hunk ./src/Yi/UI/Pango/Control.hs 21
+, controlIO
+, liftYi
+, getControl
, newBuffer
, newView
, getBuffer
hunk ./src/Yi/UI/Pango/Control.hs 35
import Prelude (map)
-import Data.List (drop, zip, take)
+import Data.Maybe (maybe, fromJust)
+import Data.IORef
+import Data.List (drop, zip, take, length)
+import Data.Prototype
import qualified Data.Rope as Rope
hunk ./src/Yi/UI/Pango/Control.hs 40
-import Yi hiding(withBuffer)
-import Yi.Window
+import qualified Data.Map as Map
+import Yi.Prelude
+import Yi.Core (startEditor, focusAllSyntax)
+import Yi.Buffer
+import Yi.Config
+import Yi.Window as Yi
import Yi.Editor
hunk ./src/Yi/UI/Pango/Control.hs 47
+import Yi.Event
+import Yi.Keymap hiding(withBuffer)
import Yi.Monad
import Yi.Style
import Yi.UI.Utils
hunk ./src/Yi/UI/Pango/Control.hs 52
-import Graphics.UI.Gtk as Gtk hiding(Point, Region)
-import Control.Monad.Reader
-import Control.Monad.State
+import Graphics.UI.Gtk as Gtk hiding(Action, Point, Region, get)
+import qualified Graphics.UI.Gtk.Gdk.Events as Gdk.Events
+import System.Glib.GError
+import Control.Monad.Reader (liftIO, ask, asks, MonadReader(..))
+import Control.Monad.State (liftM, ap, get, put, modify)
import Control.Monad.Writer (MonadIO(..))
hunk ./src/Yi/UI/Pango/Control.hs 58
-import Control.Concurrent (newMVar, modifyMVar, MVar(..))
+import Control.Concurrent (newMVar, modifyMVar, MVar(..), newEmptyMVar, putMVar, readMVar, isEmptyMVar)
import Data.Typeable
hunk ./src/Yi/UI/Pango/Control.hs 60
-import qualified Data.List.PointedList as PL (insertRight)
+import qualified Data.List.PointedList as PL (insertRight, withFocus, PointedList(..), singleton)
import Yi.Regex
import System.FilePath
hunk ./src/Yi/UI/Pango/Control.hs 63
+import qualified Yi.UI.Common as Common
+import Yi.UI.Pango (processEvent)
data Control = Control
hunk ./src/Yi/UI/Pango/Control.hs 67
- { config :: Config
- , editor :: MVar Editor
+ { controlYi :: Yi
+ , tabCache :: IORef [TabInfo]
+ , views :: IORef (Map.Map WindowRef View)
}
hunk ./src/Yi/UI/Pango/Control.hs 71
+-- { config :: Config
+-- , editor :: Editor
+-- , input :: Event -> IO ()
+-- , output :: Action -> IO ()
+-- }
hunk ./src/Yi/UI/Pango/Control.hs 77
-newtype ControlM a = ControlM { runControl' :: ReaderT Control IO a }
- deriving (Monad, MonadReader Control, MonadIO, Typeable, Functor)
+data TabInfo = TabInfo
+ { coreTab :: PL.PointedList Yi.Window
+-- , 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, MonadIO, MonadReader Control, Typeable, Functor, Applicative)
+
+-- Helper functions to avoid issues with mismatching monad libraries
+controlIO :: IO a -> ControlM a
+controlIO = liftIO
+
+getControl :: ControlM Control
+getControl = ask
+
+liftYi :: YiM a -> ControlM a
+liftYi m = do
+ yi <- asks controlYi
+ liftIO $ 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
+-- liftIO $ controlUnsafeWithEditor cfg r f
+
+startControl :: Config -> ControlM () -> IO ()
+startControl config main = do
+ 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 s = runReaderT (runControl'' f) s
+
+-- runControlEditor f yiMVar = yiMVar
+
+runAction :: Action -> ControlM ()
+runAction action = do
+ out <- liftYi $ asks output
+ liftIO $ out [action]
+
+-- | Test 2
+mkUI :: IO () -> MVar Control -> Common.UI
+mkUI main yiMVar = Common.dummyUI
+ { Common.main = main
+ , Common.end = \_ -> runControl' end yiMVar >> return ()
+ , Common.suspend = runControl' suspend yiMVar >> return ()
+ , Common.refresh = \e -> runControl' (refresh e) yiMVar >> return ()
+ , Common.layout = \e -> liftM (maybe e id) $ runControl' (doLayout e) yiMVar
+ , Common.reloadProject = \f -> runControl' (reloadProject f) yiMVar >> return ()
+ }
+
+start :: ControlM () -> UIBoot
+start main cfg ch outCh ed = catchGError (startNoMsg main cfg ch outCh ed) (\(GError _dom _code msg) -> fail msg)
+
+makeControl :: MVar Control -> YiM ()
+makeControl controlMVar = do
+ controlYi <- ask
+ tabCache <- liftIO $ newIORef []
+ views <- liftIO $ newIORef Map.empty
+ liftIO $ putMVar controlMVar Control{..}
+
+startNoMsg :: ControlM () -> UIBoot
+startNoMsg main config input output ed = do
+ control <- newEmptyMVar
+ let wrappedMain = do
+ output [makeAction $ makeControl control]
+ runControl' main control >> return ()
+ return (mkUI wrappedMain control)
+
+end :: ControlM ()
+end = do
+ liftIO $ putStrLn "Yi Control End"
+ liftIO $ mainQuit
+
+suspend :: ControlM ()
+suspend = do
+ liftIO $ putStrLn "Yi Control Suspend"
+ return ()
+
+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 <- liftIO $ 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)))
+ liftIO $ widgetQueueDraw (drawArea v)
+
+doLayout :: Editor -> ControlM Editor
+doLayout e = do
+ liftIO $ putStrLn "Yi Control Do Layout"
+ updateCache e
+ cacheRef <- asks tabCache
+ tabs <- liftIO $ readRef cacheRef
+ heights <- concat <$> mapM (getHeightsInTab e) tabs
+ let e' = (tabsA ^: fmap (fmap 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 . foldl) forceWin e' (e' ^. tabsA)
+
+getHeightsInTab :: Editor -> TabInfo -> ControlM [(WindowRef,Int,Region)]
+getHeightsInTab e tab = do
+ viewsRef <- asks views
+ vs <- liftIO $ readRef viewsRef
+ foldlM (\a w -> do
+ case Map.lookup (wkey w) vs of
+ Just v -> do
+ (_, h) <- liftIO $ 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)
+
+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') <- liftIO $ widgetGetSize $ drawArea v
+
+ font <- liftIO $ 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 <- liftIO $ layoutGetWidth layout
+ when (oldWidth /= Just width'') $ liftIO $ layoutSetWidth layout $ Just width''
+ else do (Rectangle px _py pwidth _pheight, _) <- liftIO $ layoutGetPixelExtents layout
+ liftIO $ widgetSetSizeRequest (drawArea v) (px+pwidth) (-1)
+
+ -- optimize for cursor movement
+ oldText <- liftIO $ layoutGetText layout
+ when (oldText /= text) $ liftIO $ layoutSetText layout text
+
+ (_, bosOffset, _) <- liftIO $ 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 <- liftIO $ readRef cacheRef
+ cache' <- syncTabs e (toList $ PL.withFocus tabs) cache
+ liftIO $ writeRef cacheRef cache'
+
+syncTabs :: Editor -> [(PL.PointedList Yi.Window, 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 -> PL.PointedList Yi.Window -> ControlM TabInfo
+syncTab e tab ws = do
+ -- TODO Maybe do something here
+ return tab
+
+setTabFocus :: TabInfo -> ControlM ()
+setTabFocus t = do
+ -- 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 = do
+ -- TODO this needs to close the views in the tab with callback
+ return ()
+
+removeView :: TabInfo -> View -> ControlM ()
+removeView tab view = do
+ -- TODO this needs to close the view with callback
+ return ()
+
+-- | Make a new tab.
+newTab :: Editor -> PL.PointedList Yi.Window -> ControlM TabInfo
+newTab e ws = do
+ let t' = TabInfo { coreTab = ws }
+-- cache <- syncWindows e t' (toList $ PL.withFocus ws) []
+ return t' -- { views = cache }
+
+insertTabBefore :: Editor -> PL.PointedList Yi.Window -> 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
+ t <- newTab e ws
+ return t
hunk ./src/Yi/UI/Pango/Control.hs 354
-instance MonadState Editor ControlM where
- get = readRef =<< editor <$> ask
- put v = flip modifyRef (const v) =<< editor <$> ask
+insertTab :: Editor -> PL.PointedList Yi.Window -> ControlM TabInfo
+insertTab e ws = do
+ -- vb <- vBoxNew False 1
+ -- notebookAppendPage (uiNotebook ui) vb ""
+ -- widgetShowAll $ vb
+ t <- newTab e ws
+ return t
hunk ./src/Yi/UI/Pango/Control.hs 362
-instance MonadEditor ControlM where
- askCfg = config <$> ask
- withEditor f = do
- r <- asks editor
- cfg <- asks config
- liftIO $ controlUnsafeWithEditor cfg r f
+{-
+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
+ liftIO $ 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
hunk ./src/Yi/UI/Pango/Control.hs 415
, windowRef :: WindowRef
, drawArea :: DrawingArea
, layout :: PangoLayout
+ , language :: Language
+ , metrics :: FontMetrics
, scrollWin :: ScrolledWindow
hunk ./src/Yi/UI/Pango/Control.hs 418
+ , shownTos :: IORef Point
+ , winMotionSignal :: IORef (Maybe (ConnectId DrawingArea))
}
data Iter = Iter
hunk ./src/Yi/UI/Pango/Control.hs 427
, point :: Point
}
-newControl :: Config -> IO Control
-newControl config = do
- editor <- newMVar emptyEditor
- return Control {..}
-
-runControl :: ControlM a -> Control -> IO a
-runControl f s = runReaderT (runControl' f) s
-
newBuffer :: BufferId -> String -> ControlM Buffer
newBuffer id text = do
hunk ./src/Yi/UI/Pango/Control.hs 429
- fBufRef <- liftEditor $ stringToNewBuffer id $ Rope.fromString text
+ fBufRef <- liftYi $ withEditor $ newBufferE id $ Rope.fromString text
return Buffer{..}
hunk ./src/Yi/UI/Pango/Control.hs 432
-newView :: Buffer -> ControlM View
-newView buffer = do
+newView :: Buffer -> FontDescription -> ControlM View
+newView buffer font = do
control <- ask
hunk ./src/Yi/UI/Pango/Control.hs 435
- config <- askCfg
+ config <- liftYi $ askCfg
let viewFBufRef = fBufRef buffer
hunk ./src/Yi/UI/Pango/Control.hs 437
- window <- fmap (\w -> w{height=50, winRegion = mkRegion (Point 0) (Point 2000)}) $ liftEditor $ newWindowE False viewFBufRef
- let windowRef = wkey window
- liftEditor $ modA windowsA (PL.insertRight window)
+ newWindow <- fmap (\w -> w{height=50, winRegion = mkRegion (Point 0) (Point 2000)}) $ liftYi $ withEditor $ newWindowE False viewFBufRef
+ let windowRef = wkey newWindow
+ liftYi $ withEditor $ do
+ modA windowsA (PL.insertRight newWindow)
+ e <- get
+ put $ focusAllSyntax e
drawArea <- liftIO $ drawingAreaNew
hunk ./src/Yi/UI/Pango/Control.hs 444
+ liftIO $ widgetModifyBg drawArea StateNormal $ mkCol False $ Yi.Style.background $ baseAttributes $ configStyle $ configUI config
context <- liftIO $ widgetCreatePangoContext drawArea
layout <- liftIO $ layoutEmpty context
hunk ./src/Yi/UI/Pango/Control.hs 447
- liftIO $ layoutSetText layout "Test"
+ liftIO $ layoutSetFontDescription layout (Just font)
+ language <- liftIO $ contextGetLanguage context
+ metrics <- liftIO $ contextGetMetrics context font language
+ liftIO $ layoutSetText layout ""
+
+ scrollWin <- liftIO $ scrolledWindowNew Nothing Nothing
+ liftIO $ do
+ scrolledWindowAddWithViewport scrollWin drawArea
+ scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyNever
+
+ initialTos <- liftYi $ withEditor $ withGivenBufferAndWindow0 newWindow viewFBufRef $
+ getMarkPointB =<< fromMark <$> askMarks
+ shownTos <- liftIO $ newIORef initialTos
+ winMotionSignal <- liftIO $ newIORef Nothing
+
+ let view = View {..}
+
+ liftIO $ Gtk.widgetAddEvents drawArea [KeyPressMask]
+ liftIO $ Gtk.set drawArea [Gtk.widgetCanFocus := True]
+
+ liftIO $ drawArea `Gtk.onKeyPress` \event -> do
+ putStrLn $ "Yi Control Key Press = " ++ show event
+ runControl (do
+ runAction $ makeAction $ do
+ focusWindowE windowRef
+ switchToBufferE viewFBufRef) control
+ result <- processEvent (input $ controlYi control) event
+ widgetQueueDraw drawArea
+ return result
+
+ liftIO $ drawArea `Gtk.onButtonPress` \event -> do
+ widgetGrabFocus drawArea
+ runControl (handleClick view event) control
+
+ liftIO $ drawArea `Gtk.onButtonRelease` \event -> do
+ runControl (handleClick view event) control
+
+ liftIO $ drawArea `Gtk.onScroll` \event -> do
+ runControl (handleScroll view event) control
liftIO $ drawArea `Gtk.onExpose` \event -> do
hunk ./src/Yi/UI/Pango/Control.hs 488
- (text, allAttrs, debug) <- runControl (liftEditor $ do
+ (text, allAttrs, debug, tos, rel, point, inserting) <- runControl (liftYi $ withEditor $ do
+ window <- (findWindowWith windowRef) <$> get
modA buffersA (fmap (clearSyntax . clearHighlight))
let winh = height window
let tos = max 0 (regionStart (winRegion window))
hunk ./src/Yi/UI/Pango/Control.hs 494
let bos = regionEnd (winRegion window)
+ let rel p = fromIntegral (p - tos)
withGivenBufferAndWindow0 window viewFBufRef $ do
hunk ./src/Yi/UI/Pango/Control.hs 497
- -- tos <- getMarkPointB =<< fromMark <$> askMarks
- rope <- streamB Forward tos
- point <- pointB
+ -- tos <- getMarkPointB =<< fromMark <$> askMarks
+ rope <- streamB Forward tos
+ point <- pointB
+ inserting <- getA insertingA
+
+ modeNm <- gets (withMode0 modeName)
+
-- let (tos, point, text, picture) = do runBu
-- from <- getMarkPointB =<< fromMark <$> askMarks
-- rope <- streamB Forward from
hunk ./src/Yi/UI/Pango/Control.hs 523
-- add color attributes.
let strokes = [(start',s,end') | ((start', s), end') <- zip picture (drop 1 (map fst picture) ++ [bos]),
s /= emptyAttributes]
- rel p = fromIntegral (p - tos)
allAttrs = concat $ do
(p1, Attributes fg bg _rv bd itlc udrl, p2) <- strokes
return $ [ AttrForeground (rel p1) (rel p2) (mkCol True fg)
hunk ./src/Yi/UI/Pango/Control.hs 531
, AttrUnderline (rel p1) (rel p2) (if udrl then UnderlineSingle else UnderlineNone)
, AttrWeight (rel p1) (rel p2) (if bd then WeightBold else WeightNormal)
]
- return (text, allAttrs, (picture, strokes))) control
+ return (text, allAttrs, (picture, strokes, modeNm, window, tos, bos, winh), tos, rel, point, inserting)) control
hunk ./src/Yi/UI/Pango/Control.hs 533
- putStrLn $ "Setting Layout Attributes " ++ show debug
+ -- putStrLn $ "Setting Layout Attributes " ++ show debug
layoutSetAttributes layout allAttrs
hunk ./src/Yi/UI/Pango/Control.hs 535
- putStrLn "Done Stting Layout Attributes"
+ -- putStrLn "Done Stting Layout Attributes"
dw <- widgetGetDrawWindow drawArea
gc <- gcNew dw
oldText <- layoutGetText layout
hunk ./src/Yi/UI/Pango/Control.hs 541
when (text /= oldText) $ layoutSetText layout text
drawLayout dw gc 0 0 layout
+ liftIO $ 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 do drawLine dw gc (round curx, round cury) (round $ curx + curw, round $ cury + curh)
+ else do drawRectangle dw gc False (round chx) (round chy) (if chw > 0 then round chw else 8) (round chh)
+
return True
hunk ./src/Yi/UI/Pango/Control.hs 554
- scrollWin <- liftIO $ scrolledWindowNew Nothing Nothing
- liftIO $ scrolledWindowAddWithViewport scrollWin drawArea
- return View {..}
+ liftIO $ widgetGrabFocus drawArea
+
+ tabsRef <- asks tabCache
+ ts <- liftIO $ readRef tabsRef
+ liftIO $ writeRef tabsRef (TabInfo (PL.singleton newWindow):ts)
+
+ viewsRef <- asks views
+ vs <- liftIO $ readRef viewsRef
+ liftIO $ writeRef viewsRef $ Map.insert windowRef view vs
+
+ return view
where
clearHighlight fb =
-- if there were updates, then hide the selection.
hunk ./src/Yi/UI/Pango/Control.hs 576
setBufferMode f buffer = do
let bufRef = fBufRef buffer
-- adjust the mode
- tbl <- asks (modeTable . config)
- contents <- liftEditor $ withGivenBuffer0 bufRef $ elemsB
+ tbl <- liftYi $ asks (modeTable . yiConfig)
+ contents <- liftYi $ withEditor $ withGivenBuffer0 bufRef $ elemsB
let header = take 1024 contents
hmode = case header =~ "\\-\\*\\- *([^ ]*) *\\-\\*\\-" of
AllTextSubmatches [_,m] -> m
hunk ./src/Yi/UI/Pango/Control.hs 587
Just (AnyMode emptyMode)
case mode of
AnyMode newMode -> do
- liftIO $ putStrLn $ show (f, header, modeName newMode)
- liftEditor $ withGivenBuffer0 bufRef $ setMode newMode
+ -- liftIO $ 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
hunk ./src/Yi/UI/Pango/Control.hs 596
-withBuffer Buffer{fBufRef = b} f = liftEditor $ withGivenBuffer0 b f
+withBuffer Buffer{fBufRef = b} f = liftYi $ withEditor $ withGivenBuffer0 b f
getBuffer :: View -> Buffer
getBuffer view = Buffer {fBufRef = viewFBufRef view}
hunk ./src/Yi/UI/Pango/Control.hs 604
setText :: Buffer -> String -> ControlM ()
setText b text = withBuffer b $ do
r <- regionOfB Document
+
replaceRegionClever r text
getText :: Buffer -> Iter -> Iter -> ControlM String
hunk ./src/Yi/UI/Pango/Control.hs 618
(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?
+-- modA windowsA (fromJust . PL.move winIdx)
+
+ liftIO $ case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
+ (Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
+ cid <- onMotionNotify (drawArea view) False $ \event -> do
+ 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 <- liftIO $ widgetGetDisplay (drawArea view)
+ cb <- liftIO $ 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
+ liftIO $ clipboardRequestText cb cbHandler
+ _ -> return ()
+
+ liftIO $ widgetQueueDraw (drawArea view)
+ return True
+
+handleScroll :: View -> Gdk.Events.Event -> ControlM Bool
+handleScroll view event = do
+ let editorAction = do
+ 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
+ liftIO $ 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,_) <- liftIO $ 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 $ do
+ 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 <- liftIO $ newIORef ""
+ let yiAction = do
+ txt <- withEditor (withBuffer0 (readRegionB =<< getSelectRegionB))
+ :: YiM String
+ liftIO $ writeIORef selection txt
+ runAction $ makeAction yiAction
+ txt <- liftIO $ readIORef selection
+
+ disp <- liftIO $ widgetGetDisplay (drawArea view)
+ cb <- liftIO $ clipboardGetForDisplay disp selectionPrimary
+ liftIO $ clipboardSetWithData cb [(targetString,0)]
+ (\0 -> selectionDataSetText txt >> return ()) (return ())
+
+ liftIO $ widgetQueueDraw (drawArea view)
+ return True
Context:
[IReader.hs: switch M-Del to M-0
gwe...@gmail.com**20100325154110
Ignore-this: 8a220d97977e5db509d7b6b344611ea
M-Del doesn't work with urxvt, it seems, and I am doubtful it works in general.
But M-0 will work or fail with the other bindings.
]
[Cleanup syntax files
jeffwhee...@gmail.com**20100326043211
Ignore-this: 714d6df1f570a4de23fb052b04e93944
]
[Significant cleanup, -Wall to Yi.Syntax.Tree
jeffwhee...@gmail.com**20100325075221
Ignore-this: a106e842ae56b004edab83cf7dea5f0f
]
[Cleanup Yi.Syntax.Tree (replace local function with Control.Arrow's `first`)
jeffwhee...@gmail.com**20100325063218
Ignore-this: 1819a1e305d5d52b0fef28b048141dfb
]
[Fix documentation formatting (remove broken linkification)
jeffwhee...@gmail.com**20100325063013
Ignore-this: 7bcc3f61408f4c6df696f76445aaeee3
]
[-Wall (RecursiveDo -> DoRec, requires 6.12)
jeffwhee...@gmail.com**20100325053035
Ignore-this: 36c0c99feadf155016ce86219f5f5580
]
[Display errors in configuration in both cold boot and reload
jeffwhee...@gmail.com**20100325031845
Ignore-this: 11b26dd4e1ab79736610723afe8b2cb0
]
[TAG 0.6.2.2
jeffwhee...@gmail.com**20100324171312
Ignore-this: 729a069566b7090ea9de3d2a9038f4c7
]
Patch bundle hash:
d07a10cdc3dd17ba973954e39115ddbdabbe7242
