yavie-gtk.hs

module Main ( main ) where

import Yavie
import Yavie.Editor
import Yavie.Keybind
import Yavie.Keybind.Vi

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC
import Graphics.Rendering.Cairo
import Control.Monad ( unless )

myConfig :: YavieConfig IO ( Window, DrawingArea, IMContext, PangoLayout ) ()
myConfig = YavieConfig {
  withInitEditor = defaultWithInitEditor ,
  initialize  = initializeGtk ,
  finalize     = runGtk ,
  displaySize  = const $ return ( 60, 19 ) ,
  supplyEvent  = \ifc pe -> onImContextCommit ifc pe >> onKeyPressEvent ifc pe ,
  drawDisplay  = onCanvasExposeEvent ,
  keybind      = defaultKeybind defaultCmdbind ,
  romode       = defaultRomode ,
  getReadOnlyFlag  = defaultGetReadOnlyFlag ,
  runAction  = runIOAction ,
  isEventDriven = True
 }

runGtk :: ( Window, DrawingArea, IMContext, PangoLayout ) -> IO ()
runGtk ( win, _, _, _ ) = do
  widgetShowAll win
  mainGUI

onImContextCommit ::
  ( Window, DrawingArea, IMContext, PangoLayout ) -> ( Event -> IO Bool ) -> IO ()
onImContextCommit ( _, canvas, im, _ ) pe = do
  _ <- on im imContextCommit $ \str -> do
    mapM_ ( \c -> pe $ EvKey ( KASCII c ) [ ] ) str
    widgetQueueDraw canvas
  return ()

onKeyPressEvent ::
  ( Window, DrawingArea, IMContext, PangoLayout ) -> ( Event -> IO Bool ) -> IO ()
onKeyPressEvent ( window, canvas, im, _ ) pe = do
  _ <- on window keyPressEvent $ do
    imHandled <- imContextFilterKeypress im
    if imHandled then return True else do
    keyNam  <- eventKeyName
    keyChar <- fmap keyToChar eventKeyVal
    liftIO $ case ( keyChar, keyNam ) of
         ( Just c, _ )   -> do _ <- pe $ EvKey ( KASCII c ) [ ]
                               widgetQueueDraw canvas
         ( _, "Return" ) -> do conti <- pe $ EvKey KEnter [ ]
                               unless conti mainQuit
                               widgetQueueDraw canvas
         ( _, "Escape" ) -> do _ <- pe $ EvKey KEsc [ ]
                               widgetQueueDraw canvas
         _               -> return ()
    return True
  return ()

onCanvasExposeEvent ::
  ( Window, DrawingArea, IMContext, PangoLayout ) -> IO ( Editor c ) -> IO ()
onCanvasExposeEvent ( _, canvas, _, lay ) lnsGen = do
  _ <- on canvas exposeEvent $ do
    win <- eventWindow
    gc  <- liftIO $ gcNew win
    liftIO $ do
      dl <- lnsGen
      let ins = isBoxCursor dl
          crs = cursorPosOfDpy dl
          lns = displayLines dl
      layoutSetText lay $ unlines lns
      PangoRectangle cx cy cw ch <-
        layoutIndexToPos lay ( uncurry ( xyToN lns ) crs )
      let cw_ = if ins then cw else 0
      drawRectangle win gc False ( round cx ) ( round cy ) ( round cw_ ) (round ch )
      renderWithDrawable win $ do
        moveTo 0 0
        showLayout lay
    return True
  return ()

initializeGtk :: IO ( Window, DrawingArea, IMContext, PangoLayout )
initializeGtk = do
  pc     <- cairoCreateContext Nothing
--  contextSetTextGravity pc PangoGravityEast
  lay    <- layoutText pc "おはよう"

  _ <- initGUI
  window  <- windowNew
  im      <- imMulticontextNew
  vbox    <- vBoxNew True 1
  frame   <- frameNew
  canvas  <- drawingAreaNew
  set window  [ containerChild := vbox ]
  boxPackStart vbox frame   PackGrow 0
  containerAdd frame canvas
  widgetModifyBg canvas StateNormal ( Color 65535 65535 65535 )
  _ <- onDestroy window mainQuit
  _ <- on window realize $ imContextSetClientWindow im . Just =<<
    widgetGetDrawWindow window
  _ <- on window focusInEvent $ liftIO ( imContextFocusIn im ) >> return False
  return ( window, canvas, im, lay )

main :: IO ()
main = runYavie myConfig

xyToN :: [ String ] -> Int -> Int -> Int
xyToN _            x 0 = if x < 0 then 0 else x
xyToN [ ]          _ _ = error "xyToN: cursor y is over"
xyToN ( ln : lns ) x y
  | y > 0              = ( length ln + 1 ) + xyToN lns x ( y - 1 )
  | otherwise          = error "xyToN: cursor y is negative value"