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 ((=~), AllTextSubmatches(..))
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)
}
data TabInfo = TabInfo
{ coreTab :: Tab
}
instance Show TabInfo where
show t = show (coreTab t)
newtype ControlM a = ControlM { runControl'' :: ReaderT Control IO a }
deriving (Monad, MonadBase IO, MonadReader Control, Typeable,
Functor, Applicative)
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
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 -> Control -> IO a
runControl f = runReaderT (runControl'' f)
runAction :: Action -> ControlM ()
runAction action = do
out <- liftYi $ asks yiOutput
liftBase $ out MustRefresh [action]
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 ()
refresh :: Editor -> ControlM ()
refresh e = do
updateCache e
viewsRef <- asks views
vs <- liftBase $ readIORef viewsRef
forM_ (Map.elems vs) $ \v -> do
let b = findBufferWith (viewFBufRef v) e
do
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 }
let forceWin x w = height w `seq` winRegion w `seq` x
return $ (foldl . tabFoldl) forceWin e' (e' ^. tabsA)
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
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
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)
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
(:) <$> 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 =
return tab
setTabFocus :: TabInfo -> ControlM ()
setTabFocus t =
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)
return ()
removeTab :: TabInfo -> ControlM ()
removeTab t =
return ()
removeView :: TabInfo -> View -> ControlM ()
removeView tab view =
return ()
newTab :: Editor -> Tab -> ControlM TabInfo
newTab e ws = do
let t' = TabInfo { coreTab = ws }
return t'
insertTabBefore :: Editor -> Tab -> TabInfo -> ControlM TabInfo
insertTabBefore e ws c = do
newTab e ws
insertTab :: Editor -> Tab -> ControlM TabInfo
insertTab e ws = do
newTab e ws
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 -> 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
rope <- streamB Forward tos
point <- pointB
inserting <- use insertingA
modeNm <- gets (withMode0 modeName)
let content = fst $ splitAtLine winh rope
let addNL = if R.countNewLines content == winh
then id
else (`R.snoc` '\n')
sty = configStyle $ configUI config
let text = R.toText $ addNL content
picture <- attributesPictureAndSelB sty Nothing
(mkRegion tos bos)
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
layoutSetAttributes layout allAttrs
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
(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
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 =
let h = view highlightSelectionA fb
us = view 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 $ 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
liftYi $ withEditor $ do
withGivenBuffer bufRef $ do
setMode newMode
modify clearSyntax
switchToBufferE bufRef
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
-> 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: " <> showT (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 <- liftBase $ readIORef (shownTos view)
let p1 = tos + fromIntegral layoutIndex
let winRef = windowRef view
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
window <- findWindowWith winRef <$> get
withGivenBufferAndWindow window (viewFBufRef view) $ do
moveTo p1
setVisibleSelection False
(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
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)
(_,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
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
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
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)
]