yi-0.6.0: Yi/UI/Pango.hs
{-# LANGUAGE BangPatterns, ExistentialQuantification, RecursiveDo, ParallelListComp #-}
-- Copyright (c) 2007, 2008 Jean-Philippe Bernardy
-- | This module defines a user interface implemented using gtk2hs and
-- pango for direct text rendering.
module Yi.UI.Pango (start) where
import Prelude (filter, map, round, length, take, FilePath, (/), zipWith)
import Yi.Prelude
import Yi.Buffer
import qualified Yi.Editor as Editor
import Yi.Editor hiding (windows)
import Yi.Window
import Yi.Event
import Yi.Keymap
import Yi.Monad
import qualified Yi.UI.Common as Common
import Yi.Config
import Yi.Style
import Control.Applicative
import Control.Concurrent ( yield )
import Control.Monad (ap)
import Control.Monad.Reader (liftIO, when, MonadIO)
import Control.Monad.State (gets, modify, runState, State)
import Data.Prototype
import Data.Foldable
import Data.IORef
import Data.List (nub, findIndex, zip, drop, partition, repeat)
import qualified Data.List.PointedList.Circular as PL
import Data.Maybe
import Data.Traversable
import qualified Data.Map as M
import Graphics.UI.Gtk hiding (on, Region, Window, Action, Point, Style)
import qualified Graphics.UI.Gtk.Gdk.Events as Gdk.Events
import qualified Graphics.UI.Gtk as Gtk
import Yi.UI.Gtk.ProjectTree
import Yi.UI.Gtk.Utils
import Yi.UI.Utils
------------------------------------------------------------------------
data UI = UI
{ uiWindow :: Gtk.Window
, uiBox :: VBox
, uiCmdLine :: Label
, windowCache :: IORef [WinInfo]
, uiActionCh :: Action -> IO ()
, uiConfig :: UIConfig
}
data WinInfo = WinInfo
{ coreWin :: Window
, shownRegion :: IORef Region
, renderer :: IORef (ConnectId DrawingArea)
, winMotionSignal :: IORef (Maybe (ConnectId DrawingArea))
, winLayout :: PangoLayout
, winMetrics :: FontMetrics
, textview :: DrawingArea
, modeline :: Label
, widget :: Box -- ^ Top-level widget for this window.
}
instance Show WinInfo where
show w = show (coreWin w)
mkUI :: UI -> Common.UI
mkUI ui = Common.dummyUI
{ Common.main = main ui
, Common.end = end
, Common.suspend = windowIconify (uiWindow ui)
, Common.refresh = refresh ui
, Common.prepareAction = prepareAction ui
, Common.reloadProject = reloadProject ui
}
mkFontDesc :: UIConfig -> IO FontDescription
mkFontDesc cfg = do
f <- fontDescriptionNew
fontDescriptionSetFamily f (maybe "Monospace" id (configFontName cfg))
case configFontSize cfg of
Just x -> fontDescriptionSetSize f (fromIntegral x)
-- When the font size is not set, it defaults to 0.0 for the metrics.
Nothing -> return ()
return f
askBuffer w b f = fst $ runBuffer w b f
-- | Initialise the ui
start :: UIBoot
start cfg ch outCh _ed = do
unsafeInitGUIForThreadedRTS
-- rest.
win <- windowNew
windowSetDefaultSize win 800 700
--windowFullscreen win
ico <- loadIcon "yi+lambda-fat.32.png"
windowSetIcon win ico
onKeyPress win (processEvent ch)
paned <- hPanedNew
vb <- vBoxNew False 1 -- Top-level vbox
(projectTree, _projectStore) <- projectTreeNew (outCh . singleton)
modulesTree <- treeViewNew
tabs <- notebookNew
set tabs [notebookTabPos := PosBottom]
panedAdd1 paned tabs
scrlProject <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrlProject projectTree
scrolledWindowSetPolicy scrlProject PolicyAutomatic PolicyAutomatic
notebookAppendPage tabs scrlProject "Project"
scrlModules <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrlModules modulesTree
scrolledWindowSetPolicy scrlModules PolicyAutomatic PolicyAutomatic
notebookAppendPage tabs scrlModules "Modules"
vb' <- vBoxNew False 1
panedAdd2 paned vb'
set win [ containerChild := vb ]
onDestroy win mainQuit
cmd <- labelNew Nothing
set cmd [ miscXalign := 0.01 ]
widgetModifyFont cmd =<< Just <$> mkFontDesc (configUI cfg)
set vb [ containerChild := paned,
containerChild := cmd,
boxChildPacking cmd := PackNatural ]
-- use our magic threads thingy (http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/)
timeoutAddFull (yield >> return True) priorityDefaultIdle 50
widgetShowAll win
wc <- newIORef []
let ui = UI win vb' cmd wc (outCh . singleton) (configUI cfg)
return (mkUI ui)
main :: UI -> IO ()
main _ui =
do logPutStrLn "GTK main loop running"
mainGUI
processEvent :: (Event -> IO ()) -> Gdk.Events.Event -> IO Bool
processEvent ch ev = do
-- logPutStrLn $ "Gtk.Event: " ++ show ev
-- logPutStrLn $ "Event: " ++ show (gtkToYiEvent ev)
case gtkToYiEvent ev of
Nothing -> logPutStrLn $ "Event not translatable: " ++ show ev
Just e -> ch e
return True
gtkToYiEvent :: Gdk.Events.Event -> Maybe Event
gtkToYiEvent (Gdk.Events.Key {Gdk.Events.eventKeyName = keyName, Gdk.Events.eventModifier = evModifier, Gdk.Events.eventKeyChar = char})
= fmap (\k -> Event k $ (nub $ (if isShift then filter (/= MShift) else id) $ concatMap modif evModifier)) key'
where (key',isShift) =
case char of
Just c -> (Just $ KASCII c, True)
Nothing -> (M.lookup keyName keyTable, False)
modif Gdk.Events.Control = [MCtrl]
modif Gdk.Events.Alt = [MMeta]
modif Gdk.Events.Shift = [MShift]
modif _ = []
gtkToYiEvent _ = Nothing
-- | Map GTK long names to Keys
keyTable :: M.Map String Key
keyTable = M.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)
]
-- | Clean up and go home
end :: IO ()
end = mainQuit
-- | Synchronize the windows displayed by GTK with the status of windows in the Core.
syncWindows :: Editor -> UI -> [(Window, Bool)] -- ^ windows paired with their "isFocused" state.
-> [WinInfo] -> IO [WinInfo]
syncWindows e ui (wfocused@(w,focused):ws) (c:cs)
| winkey w == winkey (coreWin c) = do when focused (setFocus c)
(:) <$> syncWin e w c <*> syncWindows e ui ws cs
| winkey w `elem` map (winkey . coreWin) cs = removeWindow ui c >> syncWindows e ui (wfocused:ws) cs
| otherwise = do c' <- insertWindowBefore e ui w c
when focused (setFocus c')
return (c':) `ap` syncWindows e ui ws (c:cs)
syncWindows e ui ws [] = mapM (insertWindowAtEnd e ui) (map fst ws)
syncWindows _e ui [] cs = mapM_ (removeWindow ui) cs >> return []
syncWin :: Editor -> Window -> WinInfo -> IO WinInfo
syncWin e w wi = do
let b = findBufferWith (bufkey w) e
reg = askBuffer w b winRegionB
logPutStrLn $ "Updated one: " ++ show w ++ " to " ++ show reg
writeRef (shownRegion wi) reg
return (wi {coreWin = w})
setFocus :: WinInfo -> IO ()
setFocus w = do
logPutStrLn $ "gtk focusing " ++ show w
hasFocus <- get (textview w) widgetIsFocus
when (not hasFocus) $ widgetGrabFocus (textview w)
removeWindow :: UI -> WinInfo -> IO ()
removeWindow i win = containerRemove (uiBox i) (widget win)
handleClick :: UI -> WinInfo -> Gdk.Events.Event -> IO Bool
handleClick ui w event = do
-- logPutStrLn $ "Click: " ++ show (eventX e, eventY e, eventClick e)
-- retrieve the clicked offset.
(_,layoutIndex,_) <- layoutXYToIndex (winLayout w) (Gdk.Events.eventX event) (Gdk.Events.eventY event)
r <- readRef (shownRegion w)
let p1 = regionStart r + fromIntegral layoutIndex
-- maybe focus the window
logPutStrLn $ "Clicked inside window: " ++ show w
wCache <- readIORef (windowCache ui)
let Just idx = findIndex (((==) `on` (winkey . coreWin)) w) wCache
focusWindow = modA windowsA (fromJust . PL.move idx)
case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
(Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
writeRef (winMotionSignal w) =<< Just <$> onMotionNotify (textview w) False (handleMove ui w p1)
_ -> do maybe (return ()) signalDisconnect =<< readRef (winMotionSignal w)
writeRef (winMotionSignal w) Nothing
let editorAction = do
b <- gets $ (bkey . findBufferWith (bufkey $ coreWin w))
case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
(Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
focusWindow
withGivenBufferAndWindow0 (coreWin w) b $ moveTo p1
(Gdk.Events.SingleClick, _) -> focusWindow
(Gdk.Events.ReleaseClick, Gdk.Events.MiddleButton) -> do
txt <- getRegE
withGivenBufferAndWindow0 (coreWin w) b $ do
pointB >>= setSelectionMarkPointB
moveTo p1
insertN txt
_ -> return ()
uiActionCh ui (makeAction editorAction)
return True
handleMove :: UI -> WinInfo -> Point -> Gdk.Events.Event -> IO Bool
handleMove ui w p0 event = do
logPutStrLn $ "Motion: " ++ show (Gdk.Events.eventX event, Gdk.Events.eventY event)
-- retrieve the clicked offset.
(_,layoutIndex,_) <- layoutXYToIndex (winLayout w) (Gdk.Events.eventX event) (Gdk.Events.eventY event)
r <- readRef (shownRegion w)
let p1 = regionStart r + fromIntegral layoutIndex
let editorAction = do
txt <- withBuffer0 $ do
if p0 /= p1
then Just <$> do
m <- selMark <$> askMarks
setMarkPointB m p0
moveTo p1
setVisibleSelection True
readRegionB =<< getSelectRegionB
else return Nothing
maybe (return ()) setRegE txt
uiActionCh ui (makeAction editorAction)
-- drawWindowGetPointer (textview w) -- be ready for next message.
return True
-- | Make A new window
newWindow :: Editor -> UI -> Window -> FBuffer -> IO WinInfo
newWindow e ui w b = mdo
f <- mkFontDesc (uiConfig ui)
ml <- labelNew Nothing
widgetModifyFont ml (Just f)
set ml [ miscXalign := 0.01 ] -- so the text is left-justified.
v <- drawingAreaNew
widgetModifyFont v (Just f)
widgetAddEvents v [Button1MotionMask]
widgetModifyBg v StateNormal $ mkCol False $ Yi.Style.background $ baseAttributes $ configStyle $ uiConfig ui
box <- if isMini w
then do
widgetSetSizeRequest v (-1) 1
prompt <- labelNew (Just $ identString b)
widgetModifyFont prompt (Just f)
hb <- hBoxNew False 1
set hb [ containerChild := prompt,
containerChild := v,
boxChildPacking prompt := PackNatural,
boxChildPacking v := PackGrow]
return (castToBox hb)
else do
vb <- vBoxNew False 1
set vb [ containerChild := v,
containerChild := ml,
boxChildPacking ml := PackNatural]
return (castToBox vb)
sig <- newIORef =<< (v `onExpose` render e ui b win)
rRef <- newIORef (askBuffer w b winRegionB)
context <- widgetCreatePangoContext v
layout <- layoutEmpty context
language <- contextGetLanguage context
metrics <- contextGetMetrics context f language
motionSig <- newIORef Nothing
layoutSetWrap layout WrapAnywhere
layoutSetFontDescription layout (Just f)
let win = WinInfo { coreWin = w
, winLayout = layout
, winMetrics = metrics
, winMotionSignal = motionSig
, textview = v
, modeline = ml
, widget = box
, renderer = sig
, shownRegion = rRef
}
return win
insertWindowBefore :: Editor -> UI -> Window -> WinInfo -> IO WinInfo
insertWindowBefore e i w _c = insertWindow e i w
insertWindowAtEnd :: Editor -> UI -> Window -> IO WinInfo
insertWindowAtEnd e i w = insertWindow e i w
insertWindow :: Editor -> UI -> Window -> IO WinInfo
insertWindow e i win = do
let buf = findBufferWith (bufkey win) e
liftIO $ do w <- newWindow e i win buf
set (uiBox i) [containerChild := widget w,
boxChildPacking (widget w) := if isMini (coreWin w) then PackNatural else PackGrow]
textview w `onButtonRelease` handleClick i w
textview w `onButtonPress` handleClick i w
widgetShowAll (widget w)
return w
refresh :: UI -> Editor -> IO ()
refresh ui e = do
let ws = Editor.windows e
let takeEllipsis s = if length s > 132 then take 129 s ++ "..." else s
set (uiCmdLine ui) [labelText := takeEllipsis (show $ statusLine e)]
cache <- readRef $ windowCache ui
logPutStrLn $ "syncing: " ++ show ws
logPutStrLn $ "with: " ++ show cache
cache' <- syncWindows e ui (toList $ PL.withFocus $ ws) cache
logPutStrLn $ "Gives: " ++ show cache'
writeRef (windowCache ui) cache'
forM_ cache' $ \w -> do
let b = findBufferWith (bufkey (coreWin w)) e
--when (not $ null $ pendingUpdates b) $
do
sig <- readIORef (renderer w)
signalDisconnect sig
writeRef (renderer w) =<< (textview w `onExpose` render e ui b w)
widgetQueueDraw (textview w)
winEls :: Point -> Int -> BufferM Yi.Buffer.Size
winEls tospnt h = savingPointB $ do
moveTo tospnt
gotoLnFrom h
p <- pointB
return (p ~- tospnt)
render :: Editor -> UI -> FBuffer -> WinInfo -> t -> IO Bool
render e ui b w _ev = do
reg <- readRef (shownRegion w)
drawWindow <- widgetGetDrawWindow $ textview w
(width, height) <- widgetGetSize $ textview w
let win = coreWin w
[width', height'] = map fromIntegral [width, height]
metrics = winMetrics w
layout = winLayout w
winh = round (height' / (ascent metrics + descent metrics))
(point, text) = askBuffer win b $ do
numChars <- winEls (regionStart reg) winh
p <- pointB
content <- nelemsB' numChars (regionStart reg)
return (p, content)
layoutSetWidth layout (Just width')
layoutSetText layout text
(_,bos,_) <- layoutXYToIndex layout width' height'
let r' = mkRegion (regionStart reg) (fromIntegral bos + regionStart reg)
-- Scroll the window when the cursor goes out of it:
logPutStrLn $ "prewin: " ++ show r'
logPutStrLn $ "point: " ++ show point
r'' <- if inRegion point r'
then return r'
else do
logPutStrLn $ "point moved out of visible region"
let (topOfScreen, numChars, text') = askBuffer win b $ do
top <- indexOfSolAbove (winh `div` 2)
numChars <- winEls top winh
content <- nelemsB' numChars top
return (top, numChars, content)
layoutSetText layout text'
return $ mkSizeRegion topOfScreen numChars
writeRef (shownRegion w) r''
logPutStrLn $ "updated: " ++ show r''
-- add color attributes.
let picture = askBuffer win b $ attributesPictureAndSelB sty (regex e) r''
sty = extractValue $ configTheme (uiConfig ui)
strokes = [(start,s,end) | ((start, s), end) <- zip picture (drop 1 (map fst picture) ++ [regionEnd r'']),
s /= emptyAttributes]
rel p = fromIntegral (p - regionStart r'')
allAttrs = [gen (rel p1) (rel p2) (mkCol isFg col)
| (p1,Attributes fg bg _rv,p2) <- strokes,
((isFg,gen),col) <- zip [(True,AttrForeground), (False,AttrBackground)] [fg,bg],
col /= Default]
layoutSetAttributes layout allAttrs
(PangoRectangle curx cury curw curh, _) <- layoutGetCursorPos layout (fromPoint (point - regionStart r''))
gc <- gcNew drawWindow
drawLayout drawWindow gc 0 0 layout
-- paint the cursor
gcSetValues gc (newGCValues { Gtk.foreground = mkCol True $ Yi.Style.foreground $ baseAttributes $ configStyle $ uiConfig ui })
drawLine drawWindow gc (round curx, round cury) (round $ curx + curw, round $ cury + curh)
return True
prepareAction :: UI -> IO (EditorM ())
prepareAction ui = do
wins <- readRef (windowCache ui)
let ws = fmap coreWin wins
rs <- mapM (readRef . shownRegion) wins
logPutStrLn $ "new wins: " ++ show wins
logPutStrLn $ "new regs: " ++ show rs
heights <- forM wins $ \w -> do
(_, h) <- widgetGetSize $ textview w
let metrics = winMetrics w
return $ round ((fromIntegral h) / (ascent metrics + descent metrics))
return $ do
let updWin w r = do
withGivenBufferAndWindow0 w (bufkey w) $ do
Just (MarkSet f _ _ t) <- getMarks w
setMarkPointB f (regionStart r)
setMarkPointB t (regionEnd r)
sequence_ $ zipWith updWin ws rs
modA windowsA (computeHeights $ heights ++ repeat 0)
-- TODO: bos needs to be set also.
-- FIXME: Get rid of 'repeat 0'; it seems to be necessary because no
-- windows are available when this is first executed.
-- | Calculate window heights, given all the windows and current height.
computeHeights :: [Int] -> PL.PointedList Window -> PL.PointedList Window
computeHeights heights ws = fst $ runState (Data.Traversable.mapM distribute ws) heights
distribute :: Window -> State [Int] Window
distribute win = case isMini win of
True -> return win {height = 1}
False -> do h <- gets head
modify tail
return win {height = h}
reloadProject :: UI -> FilePath -> 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)