module Yi.UI.Pango.Control (
Control(..)
, ControlM(..)
, Buffer(..)
, View(..)
, Iter(..)
, startControl
, runControl
, controlIO
, liftYi
, getControl
, newBuffer
, newView
, getBuffer
, setBufferMode
, withBuffer
, setText
, getText
) where
import Prelude (map)
import Data.Maybe (maybe, fromJust)
import Data.IORef
import Data.List (drop, zip, take, length)
import Data.Prototype
import qualified Data.Rope as Rope
import qualified Data.Map as Map
import Yi.Prelude
import Yi.Core (startEditor, focusAllSyntax)
import Yi.Buffer
import Yi.Config
import Yi.Window as Yi
import Yi.Editor
import Yi.Event
import Yi.Keymap hiding(withBuffer)
import Yi.Monad
import Yi.Style
import Yi.UI.Utils
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 (liftIO, ask, asks, MonadReader(..))
import Control.Monad.State (liftM, ap, get, put, modify)
import Control.Monad.Writer (MonadIO(..))
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 System.FilePath
import qualified Yi.UI.Common as Common
import Yi.UI.Pango (processEvent)
data Control = Control
{ controlYi :: Yi
, tabCache :: IORef [TabInfo]
, views :: IORef (Map.Map WindowRef View)
}
data TabInfo = TabInfo
{ coreTab :: PL.PointedList Yi.Window
}
instance Show TabInfo where
show t = show (coreTab t)
newtype ControlM a = ControlM { runControl'' :: ReaderT Control IO a }
deriving (Monad, MonadIO, MonadReader Control, Typeable, Functor, Applicative)
controlIO :: IO a -> ControlM a
controlIO = liftIO
getControl :: ControlM Control
getControl = ask
liftYi :: YiM a -> ControlM a
liftYi m = do
yi <- asks controlYi
liftIO $ runReaderT (runYiM m) yi
startControl :: Config -> ControlM () -> IO ()
startControl config main = do
startEditor (config { startFrontEnd = start main } ) Nothing
runControl' :: ControlM a -> MVar Control -> IO (Maybe a)
runControl' m yiMVar = do
empty <- isEmptyMVar yiMVar
if empty
then return Nothing
else do
yi <- readMVar yiMVar
result <- runControl m yi
return $ Just result
runControl :: ControlM a -> Control -> IO a
runControl f s = runReaderT (runControl'' f) s
runAction :: Action -> ControlM ()
runAction action = do
out <- liftYi $ asks output
liftIO $ out [action]
mkUI :: IO () -> MVar Control -> Common.UI
mkUI main yiMVar = Common.dummyUI
{ Common.main = main
, Common.end = \_ -> runControl' end yiMVar >> return ()
, Common.suspend = runControl' suspend yiMVar >> return ()
, Common.refresh = \e -> runControl' (refresh e) yiMVar >> return ()
, Common.layout = \e -> liftM (maybe e id) $ runControl' (doLayout e) yiMVar
, Common.reloadProject = \f -> runControl' (reloadProject f) yiMVar >> return ()
}
start :: ControlM () -> UIBoot
start main cfg ch outCh ed = catchGError (startNoMsg main cfg ch outCh ed) (\(GError _dom _code msg) -> fail msg)
makeControl :: MVar Control -> YiM ()
makeControl controlMVar = do
controlYi <- ask
tabCache <- liftIO $ newIORef []
views <- liftIO $ newIORef Map.empty
liftIO $ putMVar controlMVar Control{..}
startNoMsg :: ControlM () -> UIBoot
startNoMsg main config input output ed = do
control <- newEmptyMVar
let wrappedMain = do
output [makeAction $ makeControl control]
runControl' main control >> return ()
return (mkUI wrappedMain control)
end :: ControlM ()
end = do
liftIO $ putStrLn "Yi Control End"
liftIO $ mainQuit
suspend :: ControlM ()
suspend = do
liftIO $ putStrLn "Yi Control Suspend"
return ()
refresh :: Editor -> ControlM ()
refresh e = do
updateCache e
viewsRef <- asks views
vs <- liftIO $ readRef viewsRef
forM_ (Map.elems vs) $ \v -> do
let b = findBufferWith (viewFBufRef v) e
do
liftIO $ widgetQueueDraw (drawArea v)
doLayout :: Editor -> ControlM Editor
doLayout e = do
liftIO $ putStrLn "Yi Control Do Layout"
updateCache e
cacheRef <- asks tabCache
tabs <- liftIO $ readRef cacheRef
heights <- concat <$> mapM (getHeightsInTab e) tabs
let e' = (tabsA ^: fmap (fmap updateWin)) e
updateWin w = case find (\(ref,_,_) -> (wkey w == ref)) heights of
Nothing -> w
Just (_,h,rgn) -> w { height = h, winRegion = rgn }
let forceWin x w = height w `seq` winRegion w `seq` x
return $ (foldl . foldl) forceWin e' (e' ^. tabsA)
getHeightsInTab :: Editor -> TabInfo -> ControlM [(WindowRef,Int,Region)]
getHeightsInTab e tab = do
viewsRef <- asks views
vs <- liftIO $ readRef viewsRef
foldlM (\a w -> do
case Map.lookup (wkey w) vs of
Just v -> do
(_, h) <- liftIO $ widgetGetSize $ drawArea v
let lineHeight = ascent (metrics v) + descent (metrics v)
let b0 = findBufferWith (viewFBufRef v) e
rgn <- shownRegion e v b0
let ret= (windowRef v, round $ fromIntegral h / lineHeight, rgn)
return $ a ++ [ret]
Nothing -> return a)
[] (coreTab tab)
shownRegion :: Editor -> View -> FBuffer -> ControlM Region
shownRegion e v b = do
(tos, _, bos) <- updatePango e v b (layout v)
return $ mkRegion tos bos
updatePango :: Editor -> View -> FBuffer -> PangoLayout -> ControlM (Point, Point, Point)
updatePango e v b layout = do
(width', height') <- liftIO $ widgetGetSize $ drawArea v
font <- liftIO $ layoutGetFontDescription layout
let win = findWindowWith (windowRef v) e
[width'', height''] = map fromIntegral [width', height']
lineHeight = ascent (metrics v) + descent (metrics v)
winh = max 1 $ floor (height'' / lineHeight)
(tos, point, text) = askBuffer win b $ do
from <- getMarkPointB =<< fromMark <$> askMarks
rope <- streamB Forward from
p <- pointB
let content = fst $ Rope.splitAtLine winh rope
let addNL = if Rope.countNewLines content == winh
then id
else (++"\n")
return (from, p, addNL $ Rope.toString content)
config <- liftYi $ askCfg
if configLineWrap $ configUI config
then do oldWidth <- liftIO $ layoutGetWidth layout
when (oldWidth /= Just width'') $ liftIO $ layoutSetWidth layout $ Just width''
else do (Rectangle px _py pwidth _pheight, _) <- liftIO $ layoutGetPixelExtents layout
liftIO $ widgetSetSizeRequest (drawArea v) (px+pwidth) (1)
oldText <- liftIO $ layoutGetText layout
when (oldText /= text) $ liftIO $ layoutSetText layout text
(_, bosOffset, _) <- liftIO $ layoutXYToIndex layout width'' (fromIntegral winh * lineHeight 1)
return (tos, point, tos + fromIntegral bosOffset + 1)
updateCache :: Editor -> ControlM ()
updateCache e = do
let tabs = e ^. tabsA
cacheRef <- asks tabCache
cache <- liftIO $ readRef cacheRef
cache' <- syncTabs e (toList $ PL.withFocus tabs) cache
liftIO $ writeRef cacheRef cache'
syncTabs :: Editor -> [(PL.PointedList Yi.Window, Bool)] -> [TabInfo] -> ControlM [TabInfo]
syncTabs e (tfocused@(t,focused):ts) (c:cs)
| t == coreTab c =
do when focused $ setTabFocus c
(:) <$> syncTab e c t <*> syncTabs e ts cs
| t `elem` map coreTab cs =
do removeTab c
syncTabs e (tfocused:ts) cs
| otherwise =
do c' <- insertTabBefore e t c
when focused $ setTabFocus c'
return (c':) `ap` syncTabs e ts (c:cs)
syncTabs e ts [] = mapM (\(t,focused) -> do
c' <- insertTab e t
when focused $ setTabFocus c'
return c') ts
syncTabs _ [] cs = mapM_ removeTab cs >> return []
syncTab :: Editor -> TabInfo -> PL.PointedList Yi.Window -> ControlM TabInfo
syncTab e tab ws = do
return tab
setTabFocus :: TabInfo -> ControlM ()
setTabFocus t = do
return ()
askBuffer :: Yi.Window -> FBuffer -> BufferM a -> a
askBuffer w b f = fst $ runBuffer w b f
setWindowFocus :: Editor -> TabInfo -> View -> ControlM ()
setWindowFocus e t v = do
let bufferName = shortIdentString (commonNamePrefix e) $ findBufferWith (viewFBufRef v) e
window = findWindowWith (windowRef v) e
ml = askBuffer window (findBufferWith (viewFBufRef v) e) $ getModeLine (commonNamePrefix e)
return ()
removeTab :: TabInfo -> ControlM ()
removeTab t = do
return ()
removeView :: TabInfo -> View -> ControlM ()
removeView tab view = do
return ()
newTab :: Editor -> PL.PointedList Yi.Window -> ControlM TabInfo
newTab e ws = do
let t' = TabInfo { coreTab = ws }
return t'
insertTabBefore :: Editor -> PL.PointedList Yi.Window -> TabInfo -> ControlM TabInfo
insertTabBefore e ws c = do
t <- newTab e ws
return t
insertTab :: Editor -> PL.PointedList Yi.Window -> ControlM TabInfo
insertTab e ws = do
t <- newTab e ws
return t
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
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 -> String -> ControlM Buffer
newBuffer id text = do
fBufRef <- liftYi $ withEditor $ newBufferE id $ Rope.fromString 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
modA windowsA (PL.insertRight newWindow)
e <- get
put $ focusAllSyntax e
drawArea <- liftIO $ drawingAreaNew
liftIO $ widgetModifyBg drawArea StateNormal $ mkCol False $ Yi.Style.background $ baseAttributes $ configStyle $ configUI config
context <- liftIO $ widgetCreatePangoContext drawArea
layout <- liftIO $ layoutEmpty context
liftIO $ layoutSetFontDescription layout (Just font)
language <- liftIO $ contextGetLanguage context
metrics <- liftIO $ contextGetMetrics context font language
liftIO $ layoutSetText layout ""
scrollWin <- liftIO $ scrolledWindowNew Nothing Nothing
liftIO $ do
scrolledWindowAddWithViewport scrollWin drawArea
scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyNever
initialTos <- liftYi $ withEditor $ withGivenBufferAndWindow0 newWindow viewFBufRef $
getMarkPointB =<< fromMark <$> askMarks
shownTos <- liftIO $ newIORef initialTos
winMotionSignal <- liftIO $ newIORef Nothing
let view = View {..}
liftIO $ Gtk.widgetAddEvents drawArea [KeyPressMask]
liftIO $ Gtk.set drawArea [Gtk.widgetCanFocus := True]
liftIO $ drawArea `Gtk.onKeyPress` \event -> do
putStrLn $ "Yi Control Key Press = " ++ show event
runControl (do
runAction $ makeAction $ do
focusWindowE windowRef
switchToBufferE viewFBufRef) control
result <- processEvent (input $ controlYi control) event
widgetQueueDraw drawArea
return result
liftIO $ drawArea `Gtk.onButtonPress` \event -> do
widgetGrabFocus drawArea
runControl (handleClick view event) control
liftIO $ drawArea `Gtk.onButtonRelease` \event -> do
runControl (handleClick view event) control
liftIO $ drawArea `Gtk.onScroll` \event -> do
runControl (handleScroll view event) control
liftIO $ drawArea `Gtk.onExpose` \event -> do
(text, allAttrs, debug, tos, rel, point, inserting) <- runControl (liftYi $ withEditor $ do
window <- (findWindowWith windowRef) <$> get
modA buffersA (fmap (clearSyntax . clearHighlight))
let winh = height window
let tos = max 0 (regionStart (winRegion window))
let bos = regionEnd (winRegion window)
let rel p = fromIntegral (p tos)
withGivenBufferAndWindow0 window viewFBufRef $ do
rope <- streamB Forward tos
point <- pointB
inserting <- getA insertingA
modeNm <- gets (withMode0 modeName)
let content = fst $ Rope.splitAtLine winh rope
let addNL = if Rope.countNewLines content == winh
then id
else (++"\n")
sty = extractValue $ configTheme (configUI config)
let text = addNL $ Rope.toString content
picture <- attributesPictureAndSelB sty Nothing (mkRegion tos bos)
let strokes = [(start',s,end') | ((start', s), end') <- zip picture (drop 1 (map fst picture) ++ [bos]),
s /= emptyAttributes]
allAttrs = concat $ do
(p1, Attributes fg bg _rv bd itlc udrl, p2) <- strokes
return $ [ AttrForeground (rel p1) (rel p2) (mkCol True fg)
, AttrBackground (rel p1) (rel p2) (mkCol False bg)
, AttrStyle (rel p1) (rel p2) (if itlc then StyleItalic else StyleNormal)
, AttrUnderline (rel p1) (rel p2) (if udrl then UnderlineSingle else UnderlineNone)
, AttrWeight (rel p1) (rel p2) (if bd then WeightBold else WeightNormal)
]
return (text, allAttrs, (picture, strokes, modeNm, window, tos, bos, winh), tos, rel, point, inserting)) control
layoutSetAttributes layout allAttrs
dw <- widgetGetDrawWindow drawArea
gc <- gcNew dw
oldText <- layoutGetText layout
when (text /= oldText) $ layoutSetText layout text
drawLayout dw gc 0 0 layout
liftIO $ writeRef shownTos tos
(PangoRectangle curx cury curw curh, _) <- layoutGetCursorPos layout (rel point)
PangoRectangle chx chy chw chh <- layoutIndexToPos layout (rel point)
gcSetValues gc (newGCValues { Gtk.foreground = mkCol True $ Yi.Style.foreground $ baseAttributes $ configStyle $ configUI config })
if inserting
then do drawLine dw gc (round curx, round cury) (round $ curx + curw, round $ cury + curh)
else do drawRectangle dw gc False (round chx) (round chy) (if chw > 0 then round chw else 8) (round chh)
return True
liftIO $ widgetGrabFocus drawArea
tabsRef <- asks tabCache
ts <- liftIO $ readRef tabsRef
liftIO $ writeRef tabsRef (TabInfo (PL.singleton newWindow):ts)
viewsRef <- asks views
vs <- liftIO $ readRef viewsRef
liftIO $ writeRef viewsRef $ Map.insert windowRef view vs
return view
where
clearHighlight fb =
let h = getVal highlightSelectionA fb
us = getVal pendingUpdatesA fb
in highlightSelectionA ^= (h && null us) $ fb
setBufferMode :: FilePath -> Buffer -> ControlM ()
setBufferMode f buffer = do
let bufRef = fBufRef buffer
tbl <- liftYi $ asks (modeTable . yiConfig)
contents <- liftYi $ withEditor $ withGivenBuffer0 bufRef $ elemsB
let header = take 1024 contents
hmode = case header =~ "\\-\\*\\- *([^ ]*) *\\-\\*\\-" of
AllTextSubmatches [_,m] -> 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
liftYi $ withEditor $ do
withGivenBuffer0 bufRef $ do
setMode newMode
modify clearSyntax
switchToBufferE bufRef
withBuffer :: Buffer -> BufferM a -> ControlM a
withBuffer Buffer{fBufRef = b} f = liftYi $ withEditor $ withGivenBuffer0 b f
getBuffer :: View -> Buffer
getBuffer view = Buffer {fBufRef = viewFBufRef view}
setText :: Buffer -> String -> ControlM ()
setText b text = withBuffer b $ do
r <- regionOfB Document
replaceRegionClever r text
getText :: Buffer -> Iter -> Iter -> ControlM String
getText b Iter{point = p1} Iter{point = p2} = withBuffer b $ readRegionB $ mkRegion p1 p2
mkCol :: Bool
-> Yi.Style.Color -> Gtk.Color
mkCol True Default = Color 0 0 0
mkCol False Default = Color maxBound maxBound maxBound
mkCol _ (RGB x y z) = Color (fromIntegral x * 256)
(fromIntegral y * 256)
(fromIntegral z * 256)
handleClick :: View -> Gdk.Events.Event -> ControlM Bool
handleClick view event = do
control <- ask
logPutStrLn $ "Click: " ++ show (Gdk.Events.eventX event,
Gdk.Events.eventY event,
Gdk.Events.eventClick event)
(_,layoutIndex,_) <- io $ layoutXYToIndex (layout view) (Gdk.Events.eventX event) (Gdk.Events.eventY event)
tos <- readRef (shownTos view)
let p1 = tos + fromIntegral layoutIndex
let winRef = windowRef view
liftIO $ case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
(Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
cid <- onMotionNotify (drawArea view) False $ \event -> do
runControl (handleMove view p1 event) control
writeRef (winMotionSignal view) $ Just cid
_ -> do maybe (return ()) signalDisconnect =<< readRef (winMotionSignal view)
writeRef (winMotionSignal view) Nothing
case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
(Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> runAction . makeAction $ do
window <- (findWindowWith winRef) <$> get
withGivenBufferAndWindow0 window (viewFBufRef view) $ do
moveTo p1
setVisibleSelection False
(Gdk.Events.ReleaseClick, Gdk.Events.MiddleButton) -> do
disp <- liftIO $ widgetGetDisplay (drawArea view)
cb <- liftIO $ clipboardGetForDisplay disp selectionPrimary
let cbHandler Nothing = return ()
cbHandler (Just txt) = runControl (runAction . makeAction $ do
window <- (findWindowWith winRef) <$> get
withGivenBufferAndWindow0 window (viewFBufRef view) $ do
pointB >>= setSelectionMarkPointB
moveTo p1
insertN txt) control
liftIO $ clipboardRequestText cb cbHandler
_ -> return ()
liftIO $ widgetQueueDraw (drawArea view)
return True
handleScroll :: View -> Gdk.Events.Event -> ControlM Bool
handleScroll view event = do
let editorAction = do
withBuffer0 $ vimScrollB $ case Gdk.Events.eventDirection event of
Gdk.Events.ScrollUp -> (1)
Gdk.Events.ScrollDown -> 1
_ -> 0
runAction $ makeAction editorAction
liftIO $ widgetQueueDraw (drawArea view)
return True
handleMove :: View -> Point -> Gdk.Events.Event -> ControlM Bool
handleMove view p0 event = do
logPutStrLn $ "Motion: " ++ show (Gdk.Events.eventX event, Gdk.Events.eventY event)
(_,layoutIndex,_) <- liftIO $ layoutXYToIndex (layout view) (Gdk.Events.eventX event) (Gdk.Events.eventY event)
tos <- readRef (shownTos view)
let p1 = tos + fromIntegral layoutIndex
let editorAction = do
txt <- withBuffer0 $ do
if p0 /= p1
then Just <$> do
m <- selMark <$> askMarks
setMarkPointB m p0
moveTo p1
setVisibleSelection True
readRegionB =<< getSelectRegionB
else return Nothing
maybe (return ()) setRegE txt
runAction $ makeAction editorAction
selection <- liftIO $ newIORef ""
let yiAction = do
txt <- withEditor (withBuffer0 (readRegionB =<< getSelectRegionB))
:: YiM String
liftIO $ writeIORef selection txt
runAction $ makeAction yiAction
txt <- liftIO $ readIORef selection
disp <- liftIO $ widgetGetDisplay (drawArea view)
cb <- liftIO $ clipboardGetForDisplay disp selectionPrimary
liftIO $ clipboardSetWithData cb [(targetString,0)]
(\0 -> selectionDataSetText txt >> return ()) (return ())
liftIO $ widgetQueueDraw (drawArea view)
return True