yi-frontend-pango (empty) → 0.13
raw patch · 26 files changed
+2330/−0 lines, 26 filesdep +basedep +containersdep +filepathsetup-changedbinary-added
Dependencies added: base, containers, filepath, glib, gtk, microlens-platform, mtl, oo-prototypes, pango, pointedlist, text, transformers-base, yi-core, yi-language, yi-rope
Files
- Setup.hs +4/−0
- art/c-source.png binary
- art/dependencies.png binary
- art/exposed-file-module.png binary
- art/exposed-module.png binary
- art/h-source.png binary
- art/hidden-file-module.png binary
- art/hidden-module.png binary
- art/hs-source-folder.png binary
- art/license-file.png binary
- art/package.png binary
- art/plain-folder.png binary
- art/project.png binary
- art/setup-script.png binary
- art/text-file.png binary
- art/yi+lambda-fat-128.png binary
- art/yi+lambda-fat-16.png binary
- art/yi+lambda-fat-32.png binary
- art/yi+lambda-fat-64.png binary
- art/yi+lambda-fat.pdf binary
- src/Yi/Config/Default/Pango.hs +9/−0
- src/Yi/Frontend/Pango.hs +942/−0
- src/Yi/Frontend/Pango/Control.hs +859/−0
- src/Yi/Frontend/Pango/Layouts.hs +424/−0
- src/Yi/Frontend/Pango/Utils.hs +23/−0
- yi-frontend-pango.cabal +69/−0
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main :: IO ()+main = defaultMain
+ art/c-source.png view
binary file changed (absent → 197 bytes)
+ art/dependencies.png view
binary file changed (absent → 215 bytes)
+ art/exposed-file-module.png view
binary file changed (absent → 213 bytes)
+ art/exposed-module.png view
binary file changed (absent → 254 bytes)
+ art/h-source.png view
binary file changed (absent → 201 bytes)
binary file changed (absent → 229 bytes)
binary file changed (absent → 216 bytes)
+ art/hs-source-folder.png view
binary file changed (absent → 208 bytes)
+ art/license-file.png view
binary file changed (absent → 214 bytes)
+ art/package.png view
binary file changed (absent → 194 bytes)
+ art/plain-folder.png view
binary file changed (absent → 190 bytes)
+ art/project.png view
binary file changed (absent → 261 bytes)
+ art/setup-script.png view
binary file changed (absent → 245 bytes)
+ art/text-file.png view
binary file changed (absent → 183 bytes)
+ art/yi+lambda-fat-128.png view
binary file changed (absent → 22701 bytes)
+ art/yi+lambda-fat-16.png view
binary file changed (absent → 1483 bytes)
+ art/yi+lambda-fat-32.png view
binary file changed (absent → 3857 bytes)
+ art/yi+lambda-fat-64.png view
binary file changed (absent → 10133 bytes)
+ art/yi+lambda-fat.pdf view
binary file changed (absent → 6346 bytes)
+ src/Yi/Config/Default/Pango.hs view
@@ -0,0 +1,9 @@+module Yi.Config.Default.Pango (configurePango) where++import Lens.Micro.Platform ((.=))+import Yi.Frontend.Pango (start)+import Yi.Config.Lens (startFrontEndA)+import Yi.Config.Simple (ConfigM)++configurePango :: ConfigM ()+configurePango = startFrontEndA .= start
+ src/Yi/Frontend/Pango.hs view
@@ -0,0 +1,942 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module : Yi.Frontend.Pango+-- License : GPL-2+-- Maintainer : yi-devel@googlegroups.com+-- Stability : experimental+-- Portability : portable+--+-- This module defines a user interface implemented using gtk2hs and+-- pango for direct text rendering.++module Yi.Frontend.Pango (start, startGtkHook) where++import Control.Applicative+import Control.Concurrent+import Control.Exception (catch, SomeException)+import Lens.Micro.Platform hiding (set, from)+import Control.Monad hiding (forM_, mapM_, forM, mapM)+import Data.Foldable+import Data.IORef+import qualified Data.List.PointedList as PL (moveTo)+import qualified Data.List.PointedList.Circular as PL+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Data.Text (unpack, Text)+import qualified Data.Text as T+import Data.Traversable+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk hiding (Region, Window, Action , Point,+ Style, Modifier, on)+import qualified Graphics.UI.Gtk.Gdk.EventM as EventM+import qualified Graphics.UI.Gtk.Gdk.GC as Gtk+import Graphics.UI.Gtk.Gdk.GC hiding (foreground)+import Prelude hiding (error, elem, mapM_, foldl, concat, mapM)+import System.Glib.GError+import Yi.Buffer+import Yi.Config+import Yi.Debug+import Yi.Editor+import Yi.Event+import Yi.Keymap+import Yi.Layout(DividerPosition, DividerRef)+import Yi.Monad+import qualified Yi.Rope as R+import Yi.Style+import Yi.Tab+import Yi.Types (fontsizeVariation, attributes)+import qualified Yi.UI.Common as Common+import Yi.Frontend.Pango.Control (keyTable)+import Yi.Frontend.Pango.Layouts+import Yi.Frontend.Pango.Utils+import Yi.String (showT)+import Yi.UI.TabBar+import Yi.UI.Utils+import Yi.Utils+import Yi.Window++-- We use IORefs in all of these datatypes for all fields which could+-- possibly change over time. This ensures that no 'UI', 'TabInfo',+-- 'WinInfo' will ever go out of date.++data UI = UI+ { 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++-- We don't need to know the order of the windows (the layout manages+-- that) so we might as well use a map+type WindowCache = M.Map WindowRef WinInfo++data TabInfo = TabInfo+ { 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 -- ^ Top-level widget for this window.+ }++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)++ -- This will cause the textview to redraw+ 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++-- | Initialise the ui+start :: UIBoot+start = startGtkHook (const $ return ())++-- | Initialise the ui, calling a given function+-- on the Gtk window. This could be used to+-- set additional callbacks, adjusting the window+-- layout, etc.+startGtkHook :: (Gtk.Window -> IO ()) -> UIBoot+startGtkHook 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 -- Top-level vbox++ im <- imMulticontextNew+ imContextSetUsePreedit im False -- handler for preedit string not implemented++ -- Yi.Buffer.Misc.insertN for atomic input?+ 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++ -- Allow multiple lines in statusbar, GitHub issue #478+ statusbarGetMessageArea status >>= containerGetChildren >>= \case+ [w] -> labelSetSingleLineMode (castToLabel w) False+ _ -> return ()++ -- statusbarGetContextId status "global"++ 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++ -- I think this is the correct place to put it...+ userHook win++ -- use our magic threads thingy+ -- http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/+ void $ timeoutAddFull (yield >> return True) priorityDefaultIdle 50++ widgetShowAll win++ let ui = UI win tabs status tc actionCh (configUI cfg) fontRef im++ -- Keep the current tab focus up to date+ let move n pl = fromMaybe pl (PL.moveTo n pl)+ runAction = uiActionCh ui . makeAction+ -- why does this cause a hang without postGUIAsync?+ simpleNotebookOnSwitchPage (uiNotebook ui) $ \n -> postGUIAsync $+ runAction ((%=) tabsA (move n) :: EditorM ())++ return (mkUI ui)+++main :: IO ()+main = logPutStrLn "GTK main loop running" >> mainGUI++-- | Clean up and go home+end :: IO ()+end = mainQuit++-- | Modify GUI and the 'TabCache' to reflect information in 'Editor'.+updateCache :: UI -> Editor -> IO ()+updateCache ui e = do+ cache <- readIORef $ tabCache ui+ -- convert to a map for convenient lookups+ let cacheMap = mapFromFoldable . fmap (\t -> (coreTabKey t, t)) $ cache++ -- build the new 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++ -- store the new cache+ writeIORef (tabCache ui) cache'++ -- update the GUI+ simpleNotebookSet (uiNotebook ui)+ =<< forM cache' (\t -> (tabWidget t,) <$> readIORef (abbrevTitle t))+++-- | Modify GUI and given 'TabInfo' to reflect information in 'Tab'.+updateTabInfo :: Editor -> UI -> Tab -> TabInfo -> IO ()+updateTabInfo e ui tab tabInfo = do+ -- update the window cache+ 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++ -- TODO update renderer, etc?++ let lookupWin w = wCacheNew M.! w++ -- set layout+ layoutDisplaySet (layoutDisplay tabInfo)+ . fmap (winWidget . lookupWin) . tabLayout $ tab++ -- set minibox+ miniwindowDisplaySet (miniwindowPage tabInfo)+ . fmap (winWidget . lookupWin . wkey) . tabMiniWindows $ tab++ -- set focus+ setWindowFocus e ui tabInfo . lookupWin . wkey . tabFocus $ tab++updateWindow :: Editor -> UI -> Window -> WinInfo -> IO ()+updateWindow e _ui win wInfo = do+ writeIORef (inFocus wInfo) False -- see also 'setWindowFocus'+ 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 -- see also 'updateWindow'+ 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)++-- | Make the cache from the editor and the action channel+newCache :: Editor -> (Action -> IO ()) -> IO TabCache+newCache e actionCh = mapM (mkDummyTab actionCh) (e ^. tabsA)++-- | Make a new tab, and populate it+newTab :: Editor -> UI -> Tab -> IO TabInfo+newTab e ui tab = do+ t <- mkDummyTab (uiActionCh ui) tab+ updateTabInfo e ui tab t+ return t++-- | Make a minimal new tab, without any windows.+-- This is just for bootstrapping the UI; 'newTab' should normally+-- be called instead.+mkDummyTab :: (Action -> IO ()) -> Tab -> IO TabInfo+mkDummyTab 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)+++-- | Make a new window.+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 ] -- so the text is left-justified.++ -- allow the modeline to be covered up, horizontally+ 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)++ -- stops layoutGetText crashing (as of gtk2hs 0.10.1)+ 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++ -- todo: allocate event rather than configure?+ v `on` configureEvent $ handleConfigure ui++ v `on` motionNotifyEvent $ handleMove ui win+ void $ v `onExpose` render ui win+ -- also redraw when the window receives/loses focus+ uiWindow ui `on` focusInEvent $ io (widgetQueueDraw v) >> return False+ uiWindow ui `on` focusOutEvent $ io (widgetQueueDraw v) >> return False+ -- todo: consider adding an 'isDirty' flag to WinLayoutInfo,+ -- so that we don't have to recompute the Attributes when focus changes.+ 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 -- The cursor may have changed since doLayout+ cache <- readIORef $ tabCache ui+ forM_ cache $ \t -> do+ wCache <- readIORef (windowCache t)+ forM_ wCache $ \w -> do+ updateWinInfoForRendering e ui w+ widgetQueueDraw (textview w)++-- | Record all the information we need for rendering.+--+-- This information is kept in an MVar so that the PangoLayout and+-- tos/bos/buffer are in sync.+updateWinInfoForRendering :: Editor -> UI -> WinInfo -> IO ()+updateWinInfoForRendering e _ui w = modifyMVar_ (winLayoutInfo w) $ \wli -> do+ win <- readIORef (coreWin w)+ return $! wli{buffer=findBufferWith (bufkey win) e,regex=currentRegex e}++-- | Tell the 'PangoLayout' what colours to draw, and draw the 'PangoLayout'+-- and the cursor onto the screen+render :: UI -> WinInfo -> t -> IO Bool+render ui w _event =+ withMVar (winLayoutInfo w) $+ \WinLayoutInfo{winLayout=layout,tos,bos,cur,buffer=b,regex} -> do+ -- read the information+ win <- readIORef (coreWin w)++ -- add color attributes.+ 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++ -- see Note [PangoLayout width]+ -- draw the layout+ drawLayout drawWindow gc 1 0 layout++ -- calculate the cursor position+ im <- readIORef (insertingMode w)++ -- check focus, and decide whether we want a wide cursor+ 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)+ -- tell the input method+ imContextSetCursorLocation (uiInput ui) $+ Rectangle (round curX) (round curY) (round curW) (round curH)+ -- paint the cursor+ gcSetValues gc+ (newGCValues { Gtk.foreground = mkCol True . Yi.Style.foreground+ . baseAttributes . configStyle $+ uiConfig ui+ , Gtk.lineWidth = if wideCursor then 2 else 1 })++ -- tell the renderer+ if im+ then -- if we are inserting, we just want a line+ drawLine drawWindow gc (round curX, round curY)+ (round $ curX + curW, round $ curY + curH)++ -- we aren't inserting, we want a rectangle around the current character+ 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 }++ -- 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)++-- | Width, Height+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)+-- during scrolling, cur might not lie between tos and bos,+-- so we clamp it to avoid Pango errors++{-|+== Note [PangoLayout width]++We start rendering the PangoLayout one pixel from the left of the+rendering area, which means a few +/-1 offsets in Pango rendering and+point lookup code. The reason for this is to support the "wide+cursor", which is 2 pixels wide. If we started rendering the+PangoLayout directly from the left of the rendering area instead of at+a 1-pixel offset, then the "wide cursor" would only be half-displayed+when the cursor is at the beginning of the line, and would then be a+"thin cursor".++An alternative would be to special-case the wide cursor rendering at+the beginning of the line, and draw it one pixel to the right of where+it "should" be. I haven't tried this out to see how it looks.++Reiner+-}++-- we update the regex and the buffer to avoid holding on to potential garbage.+-- These will be overwritten with correct values soon, in+-- updateWinInfoForRendering.+updatePango :: UI -> FontDescription -> WinInfo -> FBuffer+ -> PangoLayout -> IO (Point, Point, Point, Point)+updatePango ui font w b layout = do+ (width_', height') <- widgetGetSize $ textview w+ let width' = max 0 (width_' - 1) -- see Note [PangoLayout width]+ fontDescriptionToStringT :: FontDescription -> IO Text+ fontDescriptionToStringT = fontDescriptionToString++ -- Resize (and possibly copy) the currently used font.+ 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+ -- This seems like it would be very expensive but I'm+ -- justifying it with that it only gets ran once per font+ -- size change. If the font size stays the same, we only+ -- enter this once per layout. We're effectivelly copying+ -- the default font for each layout that changes. An+ -- alternative would be to assign each buffer its own font+ -- but that seems a pain to maintain and if the user never+ -- changes font sizes, it's a waste of memory.+ 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++ -- allow BOS offset to be just after the last line+ 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)++ -- optimize for cursor movement+ 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)++-- | This is a hack that makes this renderer not suck in the common+-- case. There are two scenarios: we're line wrapping or we're not+-- line wrapping. This function already assumes that the contents+-- given have all the possible lines we can fit on the screen.+--+-- If we are line wrapping then the most text we'll ever need to+-- render is precisely the number of characters that can fit on the+-- screen. If that's the case, that's precisely what we do, truncate+-- up to the point where the text would be off-screen anyway.+--+-- If we aren't line-wrapping then we can't simply truncate at the max+-- number of characters: lines might be really long, but considering+-- we're not truncating, we should still be able to see every single+-- line that can fit on screen up to the screen bound. This suggests+-- that we could simply render each line up to the bound. While this+-- does work wonders for performance and would work regardless whether+-- we're wrapping or not, currently our implementation of the rest of+-- the module depends on all characters used being set into the+-- layout: if we cut some text off, painting strokes on top or going+-- to the end makes for strange effects. So currently we have no+-- choice but to render all characters in the visible lines. If you+-- have really long lines, this will kill the performance.+--+-- So here we implement the hack for the line-wrapping case. Once we+-- fix stroke painting &c, this distinction can be removed and we can+-- simply snip at the screen boundary whether we're wrapping or not+-- which actually results in great performance in the end. Until that+-- happens, only the line-wrapping case doesn't suck. Fortunately it+-- is the default.+takeContent :: UIConfig -> Int -> R.YiString -> R.YiString+takeContent cf cl t = if configLineWrap cf+ then R.take cl t+ else t++-- | Wraps the layout according to the given 'LayoutWrapMode', using+-- the specified width.+--+-- In contrast to the past, it actually implements wrapping properly+-- which was previously broken.+wrapToWidth :: PangoLayout -> LayoutWrapMode -> Double -> IO ()+wrapToWidth l wm w = do+ layoutGetWrap l >>= \wr -> case (wr, wm) of+ -- No Eq instance…+ (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 -- ^ 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)++-- * GTK Event handlers++-- | Process GTK keypress if IM fails+handleKeypress :: ([Event] -> IO ()) -- ^ Event dispatcher (Yi.Core.dispatch)+ -> 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++-- | Map Yi modifiers to GTK+modTable :: M.Map Modifier EventM.Modifier+modTable = M.fromList+ [ (MShift, EventM.Shift )+ , (MCtrl, EventM.Control)+ , (MMeta, EventM.Alt )+ , (MSuper, EventM.Super )+ , (MHyper, EventM.Hyper )+ ]++-- | Same as Gtk.on, but discards the ConnectId+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+ -- query new coordinates+ let editorAction =+ withCurrentBuffer $ scrollB $ case scrollDirection of+ ScrollUp -> negate configAmount+ ScrollDown -> configAmount+ _ -> 0 -- Left/right scrolling not supported+ configAmount = configScrollWheelAmount $ uiConfig ui+ uiActionCh ui (EditorA editorAction)+ when ifPressed $ selectArea ui w xy+ return True++handleConfigure :: UI -> EventM EConfigure Bool+handleConfigure ui = do+ -- trigger a layout+ -- why does this cause a hang without postGUIAsync?+ io $ postGUIAsync $ uiActionCh ui (makeAction (return () :: EditorM()))+ return False -- allow event to be propagated++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))++-- | Convert point coordinates to offset in Yi window+pointToOffset :: (Double, Double) -> WinInfo -> IO Point+pointToOffset (x,y) w =+ withMVar (winLayoutInfo w) $ \WinLayoutInfo{winLayout,tos,bufEnd} -> do+ im <- readIORef (insertingMode w)++ -- see Note [PangoLayout width]+ (_, charOffsetX, extra) <- layoutXYToIndex winLayout (max 0 (x-1)) 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)+ -- drawWindowGetPointer (textview w) -- be ready for next message.++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)++-- | Set selection clipboard contents to current selection+setSelectionClipboard :: UI -> WinInfo -> Clipboard -> IO ()+setSelectionClipboard ui _w cb = do+ -- Why uiActionCh doesn't allow returning values?+ 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
+ src/Yi/Frontend/Pango/Control.hs view
@@ -0,0 +1,859 @@+{-# 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+import Yi.String (showT)+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 yiOutput+ liftBase $ out MustRefresh [action]++-- | Test 2+mkUI :: IO () -> MVar Control -> Common.UI Editor+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 -> fmap (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 $ readIORef 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 $ readIORef cacheRef+ dims <- concat <$> mapM (getDimensionsInTab e) tabs+ let e' = (tabsA %~ fmap (mapWindows updateWin)) e+ updateWin w = case find (\(ref,_,_,_) -> (wkey w == ref)) dims of+ Nothing -> w+ Just (_, wi, h,rgn) -> w { width = wi+ , 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)++-- | Width, Height+getDimensionsInTab :: Editor -> TabInfo -> ControlM [(WindowRef,Int,Int,Region)]+getDimensionsInTab e tab = do+ viewsRef <- asks views+ vs <- liftBase $ readIORef viewsRef+ foldlM (\a w ->+ case Map.lookup (wkey w) vs of+ Just v -> do+ (wi, h) <- liftBase $ widgetGetSize $ drawArea v+ let lineHeight = ascent (metrics v) + descent (metrics v)+ charWidth = Gtk.approximateCharWidth $ metrics v+ b0 = findBufferWith (viewFBufRef v) e+ rgn <- shownRegion e v b0+ let ret= (windowRef v, round $ fromIntegral wi / charWidth, + 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 <- (use . markPointA) =<< fromMark <$> askMarks+ rope <- streamB Forward from+ p <- pointB+ let content = fst $ splitAtLine winh rope+ -- allow BOS offset to be just after the last line+ let addNL = if R.countNewLines content == winh+ then id+ else (`R.snoc` '\n')+ return (from, p, R.toText $ addNL 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 $ readIORef cacheRef+ cache' <- syncTabs e (toList $ PL.withFocus tabs) cache+ liftBase $ writeIORef 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 (length $ commonNamePrefix e) $+ findBufferWith (viewFBufRef v) e+ window = findWindowWith (windowRef v) e+ ml = askBuffer window (findBufferWith (viewFBufRef v) e) $+ getModeLine (T.pack <$> 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 -> R.YiString -> ControlM Buffer+newBuffer id text = do+ fBufRef <- liftYi . withEditor . newBufferE id $ 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 . withGivenBufferAndWindow newWindow viewFBufRef $+ (use . markPointA) =<< 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 (yiInput $ 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)++ withGivenBufferAndWindow 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 $ splitAtLine winh rope+ -- allow BOS offset to be just after the last line+ let addNL = if R.countNewLines content == winh+ then id+ else (`R.snoc` '\n')+ sty = configStyle $ configUI config+ -- attributesPictureAndSelB sty (currentRegex e)+ -- (mkRegion tos bos)+ -- return (from, p, addNL $ Rope.toString content,+ -- picture)+ let text = R.toText $ addNL 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 $ writeIORef 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 $ readIORef 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 $ writeIORef tabsRef (TabInfo (makeTab1 0 newWindow):ts)++ viewsRef <- asks views+ vs <- liftBase $ readIORef viewsRef+ liftBase $ writeIORef 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 $ withGivenBuffer bufRef elemsB+ let header = R.toString $ R.take 1024 contents+ hmode = case header =~ ("\\-\\*\\- *([^ ]*) *\\-\\*\\-" :: String) of+ AllTextSubmatches [_,m] -> T.pack 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+ withGivenBuffer bufRef $ do+ setMode newMode+ modify clearSyntax+ switchToBufferE bufRef+ -- withEditor focusAllSyntax++withBuffer :: Buffer -> BufferM a -> ControlM a+withBuffer Buffer{fBufRef = b} f = liftYi $ withGivenBuffer b f++getBuffer :: View -> Buffer+getBuffer view = Buffer {fBufRef = viewFBufRef view}++setText :: Buffer -> YiString -> ControlM ()+setText b text = withBuffer b $ do+ r <- regionOfB Document+ replaceRegionB r text++getText :: Buffer -> Iter -> Iter -> ControlM Text+getText b Iter{point = p1} Iter{point = p2} =+ fmap toText . 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: " <> showT (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 <- liftBase $ readIORef (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+ writeIORef (winMotionSignal view) $ Just cid++ _ -> do+ maybe (return ()) signalDisconnect =<< readIORef (winMotionSignal view)+ writeIORef (winMotionSignal view) Nothing++ case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of+ (Gdk.Events.SingleClick, Gdk.Events.LeftButton) ->+ runAction . EditorA $ do+ -- b <- gets $ (bkey . findBufferWith (viewFBufRef view))+ -- focusWindow+ window <- findWindowWith winRef <$> get+ withGivenBufferAndWindow 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 :: Maybe R.YiString -> IO ()+ cbHandler Nothing = return ()+ cbHandler (Just txt) = runControl (runAction . EditorA $ do+ window <- findWindowWith winRef <$> get+ withGivenBufferAndWindow window (viewFBufRef view) $ do+ pointB >>= setSelectionMarkPointB+ moveTo p1+ insertN txt) control+ liftBase $ clipboardRequestText cb (cbHandler . fmap R.fromText)+ _ -> return ()++ liftBase $ widgetQueueDraw (drawArea view)+ return True++handleScroll :: View -> Gdk.Events.Event -> ControlM Bool+handleScroll view event = do+ let editorAction =+ withCurrentBuffer $ vimScrollB $ case Gdk.Events.eventDirection event of+ Gdk.Events.ScrollUp -> -1+ Gdk.Events.ScrollDown -> 1+ _ -> 0 -- Left/right scrolling not supported++ runAction $ EditorA editorAction+ liftBase $ widgetQueueDraw (drawArea view)+ return True++handleMove :: View -> Point -> Gdk.Events.Event -> ControlM Bool+handleMove view p0 event = do+ logPutStrLn $ "Motion: " <> showT (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 <- liftBase $ readIORef (shownTos view)+ let p1 = tos + fromIntegral layoutIndex+++ let editorAction = do+ txt <- withCurrentBuffer $+ if p0 /= p1+ then Just <$> do+ m <- selMark <$> askMarks+ markPointA 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 <- withCurrentBuffer (readRegionB =<< getSelectRegionB)+ :: YiM R.YiString+ 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 $ R.toText 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: " <> showT 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})+ = (\k -> Event k $ nub $ notMShift $ 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 _ = []+ notMShift | isShift = filter (/= MShift)+ | otherwise = id+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)+ ]
+ src/Yi/Frontend/Pango/Layouts.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module : Yi.Frontend.Pango.Layouts+-- License : GPL-2+-- Maintainer : yi-devel@googlegroups.com+-- Stability : experimental+-- Portability : portable+--+-- Provides abstract controls which implement 'Yi.Layout.Layout's and+-- which manage the minibuffer.+--+-- The implementation strategy is to first construct the layout+-- managers @WeightedStack@ (implementing the 'Stack' constructor) and+-- @SlidingPair@ (implementing the 'Pair' constructor), and then+-- construct 'LayoutDisplay' as a tree of these, mirroring the+-- structure of 'Layout'.++module Yi.Frontend.Pango.Layouts (+ -- * Getting the underlying widget+ WidgetLike(..),+ -- * Window layout+ LayoutDisplay,+ layoutDisplayNew,+ layoutDisplaySet,+ layoutDisplayOnDividerMove,+ -- * Miniwindow layout+ MiniwindowDisplay,+ miniwindowDisplayNew,+ miniwindowDisplaySet,+ -- * Tabs+ SimpleNotebook,+ simpleNotebookNew,+ simpleNotebookSet,+ simpleNotebookOnSwitchPage,+ -- * Utils+ update,+ ) where++import Control.Applicative+import Control.Arrow (first)+import Control.Monad hiding (mapM, forM)+import Data.Foldable (toList)+import Data.IORef+import qualified Data.List.PointedList as PL+import qualified Data.Text as T+import Data.Traversable+import Graphics.UI.Gtk as Gtk hiding(Orientation, Layout)+import Prelude hiding (mapM)+import Yi.Layout(Orientation(..), RelativeSize, DividerPosition,+ Layout(..), DividerRef)++class WidgetLike w where+ -- | Extracts the main widget. This is the widget to be added to the GUI.+ baseWidget :: w -> Widget++----------------------- The WeightedStack type+{- | A @WeightedStack@ is like a 'VBox' or 'HBox', except that we may+specify the ratios of the areas of the child widgets (so this+implements the 'Stack' constructor of 'Yi.Layout.Layout'.++Essentially, we implement this layout manager from scratch, by+implementing the 'sizeRequest' and 'sizeAllocate' signals by hand (see+the 'Container' documentation for details, and+http://www.ibm.com/developerworks/linux/library/l-widget-pygtk/ for an+example in Python). Ideally, we would directly subclass the abstract+class 'Container', but Gtk2hs doesn't directly support this. Instead,+we start off with the concrete class 'Fixed', and just override its+layout behaviour.+-}++newtype WeightedStack = WS Fixed+ deriving(GObjectClass, ObjectClass, WidgetClass,ContainerClass)++type StackDescr = [(Widget, RelativeSize)]++weightedStackNew :: Orientation -> StackDescr -> IO WeightedStack+weightedStackNew o s = do+ when (any ((<= 0) . snd) s) $ error+ "Yi.Frontend.Pango.WeightedStack.WeightedStack: all weights must be positive"+ l <- fixedNew+ set l (fmap ((containerChild :=) . fst) s)+ void $ Gtk.on l sizeRequest (doSizeRequest o s)+ void $ Gtk.on l sizeAllocate (relayout o s)+ return (WS l)++-- | Requests the smallest size so that each widget gets its requested size+doSizeRequest :: Orientation -> StackDescr -> IO Requisition+doSizeRequest o s =+ let+ (requestAlong, requestAcross) =+ case o of+ Horizontal ->+ (\(Requisition w _) -> fromIntegral w,+ \(Requisition _ h) -> h)+ Vertical ->+ (\(Requisition _ h) -> fromIntegral h,+ \(Requisition w _) -> w)++ totalWeight = sum . fmap snd $ s+ reqsize (request, relSize) = requestAlong request / relSize+ sizeAlong widgetRequests =+ totalWeight * (maximum . fmap reqsize $ widgetRequests)+ sizeAcross widgetRequests =+ maximum . fmap (requestAcross . fst) $ widgetRequests+ mkRequisition wr =+ case o of+ Horizontal -> Requisition (round $ sizeAlong wr) (sizeAcross wr)+ Vertical -> Requisition (sizeAcross wr) (round $ sizeAlong wr)+ swreq (w, relSize) = (,relSize) <$> widgetSizeRequest w+ in+ boundRequisition =<< mkRequisition <$> mapM swreq s+++-- | Bounds the given requisition to not exceed screen dimensions+boundRequisition :: Requisition -> IO Requisition+boundRequisition r@(Requisition w h) =+ do+ mscr <- screenGetDefault+ case mscr of+ Just scr -> Requisition <$> (min w <$> screenGetWidth scr)+ <*> (min h <$> screenGetHeight scr)+ Nothing -> return r++-- | Position the children appropriately for the given width and height+relayout :: Orientation -> StackDescr -> Rectangle -> IO ()+relayout o s (Rectangle x y width height) =+ let+ totalWeight = sum . fmap snd $ s+ totalSpace = fromIntegral $+ case o of+ Horizontal -> width+ Vertical -> height+ wtMult = totalSpace / totalWeight+ calcPosition pos (widget, wt) = (pos + wt * wtMult,+ (pos, wt * wtMult, widget))+ widgetToRectangle (round -> pos, round -> size, widget) =+ case o of+ Horizontal -> (Rectangle pos y size height, widget)+ Vertical -> (Rectangle x pos width size, widget)+ startPosition = fromIntegral $+ case o of+ Horizontal -> x+ Vertical -> y+ widgetPositions =+ fmap widgetToRectangle (snd (mapAccumL calcPosition startPosition s))+ in forM_ widgetPositions $ \(rect, widget) -> widgetSizeAllocate widget rect++------------------------------------------------------- SlidingPair++{-|+'SlidingPair' implements the 'Pair' constructor.++Most of what is needed is already implemented by the 'HPaned' and+'VPaned' classes. The main feature added by 'SlidingPair' is that the+divider position, *as a fraction of the available space*, remains+constant even when resizing.+-}++newtype SlidingPair = SP Paned+ deriving(GObjectClass, ObjectClass, WidgetClass, ContainerClass)++slidingPairNew :: (WidgetClass w1, WidgetClass w2) => Orientation -> w1 -> w2+ -> DividerPosition+ -> (DividerPosition -> IO ())+ -> IO SlidingPair+slidingPairNew o w1 w2 pos handleNewPos = do+ p <-+ case o of+ Horizontal -> toPaned <$> hPanedNew+ Vertical -> toPaned <$> vPanedNew+ panedPack1 p w1 True True+ panedPack2 p w2 True True++{- We want to catch the sizeAllocate signal. If this event is+called, two things could have happened: the size could have changed;+or the slider could have moved. We want to correct the slider+position, but only if the size has changed. Furthermore, if the size+only changes in the direction /orthogonal/ to the slider, then there+is also no need to correct the slider position.++-}++ posRef <- newIORef pos+ sizeRef <- newIORef 0++ void $ Gtk.on p sizeAllocate $ \(Rectangle _ _ w h) ->+ do+ oldSz <- readIORef sizeRef+ oldPos <- readIORef posRef++ let sz = case o of+ Horizontal -> w+ Vertical -> h+ writeIORef sizeRef sz+ when (sz /= 0) $+ if sz == oldSz+ then do -- the slider was moved; store its new position+ sliderPos <- get p panedPosition+ let newPos = fromIntegral sliderPos / fromIntegral sz+ writeIORef posRef newPos+ when (oldPos /= newPos) $ handleNewPos newPos+ else -- the size was changed; restore the slider position and+ -- save the new position+ set p [ panedPosition := round (oldPos * fromIntegral sz) ]++ return (SP p)++----------------------------- LayoutDisplay+-- | A container implements 'Layout's.+data LayoutDisplay+ = LD {+ mainWidget :: Bin,+ implWidget :: IORef (Maybe LayoutImpl),+ dividerCallbacks :: IORef [DividerRef -> DividerPosition -> IO ()]+ }++-- | Tree mirroring 'Layout', which holds the layout widgets for 'LayoutDisplay'+data LayoutImpl+ = SingleWindowI {+ singleWidget :: Widget+ }+ | StackI {+ orientationI :: Orientation,+ winsI :: [(LayoutImpl, RelativeSize)],+ stackWidget :: WeightedStack+ }+ | PairI {+ orientationI :: Orientation,+ pairFstI :: LayoutImpl,+ pairSndI :: LayoutImpl,+ divRefI :: DividerRef,+ pairWidget :: SlidingPair+ }++--- construction+layoutDisplayNew :: IO LayoutDisplay+layoutDisplayNew = do+ cbRef <- newIORef []+ implRef <- newIORef Nothing+ box <- toBin <$> alignmentNew 0 0 1 1+ return (LD box implRef cbRef)++-- | Registers a callback to a divider changing position. (There is+-- currently no way to unregister.)+layoutDisplayOnDividerMove :: LayoutDisplay+ -> (DividerRef -> DividerPosition -> IO ())+ -> IO ()+layoutDisplayOnDividerMove ld cb = modifyIORef (dividerCallbacks ld) (cb:)++--- changing the layout++-- | Sets the layout to the given schema.+--+-- * it is permissible to add or remove widgets in this process.+--+-- * as an optimisation, this function will first check whether the+-- layout has actually changed (so the caller need not be concerned+-- with this)+--+-- * will run 'widgetShowAll', and hence will show the underlying widgets too+layoutDisplaySet :: LayoutDisplay -> Layout Widget -> IO ()+layoutDisplaySet ld lyt = do+ mimpl <- readIORef (implWidget ld)++ let applyLayout = do+ impl' <- buildImpl (runCb $ dividerCallbacks ld) lyt+ widgetShowAll (outerWidget impl')+ set (mainWidget ld) [containerChild := outerWidget impl']+ writeIORef (implWidget ld) (Just impl')++ case mimpl of+ Nothing -> applyLayout+ Just impl -> unless (sameLayout impl lyt) $ do+ unattachWidgets (toContainer $ mainWidget ld) impl+ applyLayout++runCb :: IORef [DividerRef -> DividerPosition -> IO ()]+ -> DividerRef -> DividerPosition -> IO ()+runCb cbRef dRef dPos = readIORef cbRef >>= mapM_ (\cb -> cb dRef dPos)++buildImpl :: (DividerRef -> DividerPosition -> IO ())+ -> Layout Widget -> IO LayoutImpl+buildImpl cb = go+ where+ go (SingleWindow w) = return (SingleWindowI w)+ go (s@Stack{}) = do+ impls <- forM (wins s) $ \(lyt,relSize) -> (,relSize) <$> go lyt+ ws <- weightedStackNew (orientation s) (first outerWidget <$> impls)+ return (StackI (orientation s) impls ws)+ go (p@Pair{}) = do+ w1 <- go (pairFst p)+ w2 <- go (pairSnd p)+ sp <- slidingPairNew (orientation p) (outerWidget w1)+ (outerWidget w2) (divPos p) (cb $ divRef p)+ return $ PairI (orientation p) w1 w2 (divRef p) sp++-- | true if the displayed layout agrees with the given schema, other+-- than divider positions+sameLayout :: LayoutImpl -> Layout Widget -> Bool+sameLayout (SingleWindowI w) (SingleWindow w') = w == w'+sameLayout (s@StackI{}) (s'@Stack{}) =+ orientationI s == orientation s'+ && length (winsI s) == length (wins s')+ && and (zipWith (\(impl, relSize) (layout, relSize') ->+ relSize == relSize' && sameLayout impl layout)+ (winsI s) (wins s'))+sameLayout (p@PairI{}) (p'@Pair{}) =+ orientationI p == orientation p'+ && divRefI p == divRef p'+ && sameLayout (pairFstI p) (pairFst p')+ && sameLayout (pairSndI p) (pairSnd p')+sameLayout _ _ = False++-- removes all widgets from the layout+unattachWidgets :: Container -> LayoutImpl -> IO ()+unattachWidgets parent (SingleWindowI w) = containerRemove parent w+unattachWidgets parent s@StackI{} = do+ containerRemove parent (stackWidget s)+ mapM_ (unattachWidgets (toContainer $ stackWidget s) . fst) (winsI s)+unattachWidgets parent p@PairI{} = do+ containerRemove parent (pairWidget p)+ mapM_ (unattachWidgets (toContainer $ pairWidget p)) [pairFstI p, pairSndI p]+++-- extract the main widget from the tree+outerWidget :: LayoutImpl -> Widget+outerWidget s@SingleWindowI{} = singleWidget s+outerWidget s@StackI{} = toWidget . stackWidget $ s+outerWidget p@PairI{} = toWidget . pairWidget $ p++instance WidgetLike LayoutDisplay where+ baseWidget = toWidget . mainWidget++---------------- MiniwindowDisplay+data MiniwindowDisplay+ = MD+ { mwdMainWidget :: VBox,+ mwdWidgets :: IORef [Widget]+ }++miniwindowDisplayNew :: IO MiniwindowDisplay+miniwindowDisplayNew = do+ vb <- vBoxNew False 1+ wsRef <- newIORef []+ return (MD vb wsRef)++instance WidgetLike MiniwindowDisplay where+ baseWidget = toWidget . mwdMainWidget++miniwindowDisplaySet :: MiniwindowDisplay -> [Widget] -> IO ()+miniwindowDisplaySet mwd ws = do+ curWs <- readIORef (mwdWidgets mwd)++ -- we could be more careful here, and only remove the widgets which we need to.+ when (ws /= curWs) $ do+ forM_ curWs $ containerRemove (mwdMainWidget mwd)+ forM_ ws $ \w -> boxPackEnd (mwdMainWidget mwd) w PackNatural 0+ widgetShowAll $ mwdMainWidget mwd+ writeIORef (mwdWidgets mwd) ws+++---------------------- SimpleNotebook+data SimpleNotebook+ = SN+ { snMainWidget :: Notebook,+ snTabs :: IORef (Maybe (PL.PointedList (Widget, T.Text)))+ }++instance WidgetLike SimpleNotebook where+ baseWidget = toWidget . snMainWidget++-- | Constructs an empty notebook+simpleNotebookNew :: IO SimpleNotebook+simpleNotebookNew = do+ nb <- notebookNew+ ts <- newIORef Nothing+ return (SN nb ts)++-- | Sets the tabs+simpleNotebookSet :: SimpleNotebook -> PL.PointedList (Widget, T.Text) -> IO ()+simpleNotebookSet sn ts = do+ curTs <- readIORef (snTabs sn)++ let nb = snMainWidget sn+ tsList = toList ts+ curTsList = maybe [] toList curTs++ -- the common case is no change at all+ when (curTs /= Just ts) $ do++ -- update the tabs, if they have changed+ when (fmap fst curTsList /= fmap fst tsList) $ do+ forM_ curTsList $ const (notebookRemovePage nb (-1))+ forM_ tsList $ uncurry (notebookAppendPage nb)++ -- now update the titles if they have changed+ forM_ tsList $ \(w,s) -> update nb (notebookChildTabLabel w) s++ -- now set the focus+ p <- notebookPageNum nb (fst $ PL._focus ts)+ maybe (return ()) (update nb notebookPage) p++ -- write the new status+ writeIORef (snTabs sn) (Just ts)++ -- display!+ widgetShowAll nb+++-- | The 'onSwitchPage' callback+simpleNotebookOnSwitchPage :: SimpleNotebook -> (Int -> IO ()) -> IO ()+simpleNotebookOnSwitchPage sn = void . (snMainWidget sn `on` switchPage)+++------------------- Utils+-- Only set an attribute if has actually changed.+-- This makes setting window titles much faster.+update :: (Eq a) => o -> ReadWriteAttr o a a -> a -> IO ()+update w attr val = do oldVal <- get w attr+ when (val /= oldVal) $ set w [attr := val]
+ src/Yi/Frontend/Pango/Utils.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Random GTK utils+module Yi.Frontend.Pango.Utils where++import Control.Exception (catch, throw)++import Data.Text (append)+import Paths_yi_frontend_pango+import System.FilePath+import Graphics.UI.Gtk+import System.Glib.GError++loadIcon :: FilePath -> IO Pixbuf+loadIcon fpath = do+ iconfile <- getDataFileName $ "art" </> fpath+ icoProject <-+ catch (pixbufNewFromFile iconfile)+ (\(GError dom code msg) ->+ throw $ GError dom code $+ msg `append` " -- use the yi_datadir environment variable to"+ `append` " specify an alternate location")+ pixbufAddAlpha icoProject (Just (0,255,0))
+ yi-frontend-pango.cabal view
@@ -0,0 +1,69 @@+-- This file has been generated from package.yaml by hpack version 0.14.0.+--+-- see: https://github.com/sol/hpack++name: yi-frontend-pango+version: 0.13+synopsis: Pango frontend for Yi editor+category: Yi+homepage: https://github.com/yi-editor/yi#readme+bug-reports: https://github.com/yi-editor/yi/issues+maintainer: Yi developers <yi-devel@googlegroups.com>+license: GPL-2+build-type: Simple+cabal-version: >= 1.10++data-files:+ art/c-source.png+ art/dependencies.png+ art/exposed-file-module.png+ art/exposed-module.png+ art/h-source.png+ art/hidden-file-module.png+ art/hidden-module.png+ art/hs-source-folder.png+ art/license-file.png+ art/package.png+ art/plain-folder.png+ art/project.png+ art/setup-script.png+ art/text-file.png+ art/yi+lambda-fat-128.png+ art/yi+lambda-fat-16.png+ art/yi+lambda-fat-32.png+ art/yi+lambda-fat-64.png+ art/yi+lambda-fat.pdf++source-repository head+ type: git+ location: https://github.com/yi-editor/yi++library+ hs-source-dirs:+ src+ ghc-options: -Wall -ferror-spans+ build-depends:+ base >= 4.8 && < 5+ , containers+ , filepath+ , glib >= 0.13 && < 0.14+ , gtk >= 0.13 && < 0.15+ , microlens-platform+ , mtl+ , oo-prototypes+ , pango >= 0.13 && < 0.14+ , pointedlist+ , text+ , transformers-base+ , yi-core+ , yi-language+ , yi-rope+ exposed-modules:+ Yi.Config.Default.Pango+ Yi.Frontend.Pango+ Yi.Frontend.Pango.Control+ other-modules:+ Yi.Frontend.Pango.Layouts+ Yi.Frontend.Pango.Utils+ Paths_yi_frontend_pango+ default-language: Haskell2010