diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/art/c-source.png b/art/c-source.png new file mode 100644 Binary files /dev/null and b/art/c-source.png differ diff --git a/art/dependencies.png b/art/dependencies.png new file mode 100644 Binary files /dev/null and b/art/dependencies.png differ diff --git a/art/exposed-file-module.png b/art/exposed-file-module.png new file mode 100644 Binary files /dev/null and b/art/exposed-file-module.png differ diff --git a/art/exposed-module.png b/art/exposed-module.png new file mode 100644 Binary files /dev/null and b/art/exposed-module.png differ diff --git a/art/h-source.png b/art/h-source.png new file mode 100644 Binary files /dev/null and b/art/h-source.png differ diff --git a/art/hidden-file-module.png b/art/hidden-file-module.png new file mode 100644 Binary files /dev/null and b/art/hidden-file-module.png differ diff --git a/art/hidden-module.png b/art/hidden-module.png new file mode 100644 Binary files /dev/null and b/art/hidden-module.png differ diff --git a/art/hs-source-folder.png b/art/hs-source-folder.png new file mode 100644 Binary files /dev/null and b/art/hs-source-folder.png differ diff --git a/art/license-file.png b/art/license-file.png new file mode 100644 Binary files /dev/null and b/art/license-file.png differ diff --git a/art/package.png b/art/package.png new file mode 100644 Binary files /dev/null and b/art/package.png differ diff --git a/art/plain-folder.png b/art/plain-folder.png new file mode 100644 Binary files /dev/null and b/art/plain-folder.png differ diff --git a/art/project.png b/art/project.png new file mode 100644 Binary files /dev/null and b/art/project.png differ diff --git a/art/setup-script.png b/art/setup-script.png new file mode 100644 Binary files /dev/null and b/art/setup-script.png differ diff --git a/art/text-file.png b/art/text-file.png new file mode 100644 Binary files /dev/null and b/art/text-file.png differ diff --git a/art/yi+lambda-fat-128.png b/art/yi+lambda-fat-128.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-128.png differ diff --git a/art/yi+lambda-fat-16.png b/art/yi+lambda-fat-16.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-16.png differ diff --git a/art/yi+lambda-fat-32.png b/art/yi+lambda-fat-32.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-32.png differ diff --git a/art/yi+lambda-fat-64.png b/art/yi+lambda-fat-64.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-64.png differ diff --git a/art/yi+lambda-fat.pdf b/art/yi+lambda-fat.pdf new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat.pdf differ diff --git a/src/Yi/Config/Default/Pango.hs b/src/Yi/Config/Default/Pango.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Config/Default/Pango.hs @@ -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 diff --git a/src/Yi/Frontend/Pango.hs b/src/Yi/Frontend/Pango.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Frontend/Pango.hs @@ -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 diff --git a/src/Yi/Frontend/Pango/Control.hs b/src/Yi/Frontend/Pango/Control.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Frontend/Pango/Control.hs @@ -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) + ] diff --git a/src/Yi/Frontend/Pango/Layouts.hs b/src/Yi/Frontend/Pango/Layouts.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Frontend/Pango/Layouts.hs @@ -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] diff --git a/src/Yi/Frontend/Pango/Utils.hs b/src/Yi/Frontend/Pango/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Frontend/Pango/Utils.hs @@ -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)) diff --git a/yi-frontend-pango.cabal b/yi-frontend-pango.cabal new file mode 100644 --- /dev/null +++ b/yi-frontend-pango.cabal @@ -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 +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