yavie-x11.hs

{-# LANGUAGE FlexibleContexts #-}

module Main ( main ) where

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

import Graphics.X11
import Graphics.X11.Xft
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xim
import Data.Bits
import Control.Monad       ( zipWithM_, when, unless )
import Control.Monad.Tools

import Data.IORef -- just hack
import System.IO.Unsafe
import System.Exit
import System.Locale.SetLocale
import Data.Time
import Data.Maybe
import Data.Convertible
import Foreign.C.Types

myConfig :: YavieConfig IO XVars ()
myConfig = YavieConfig {

  isEventDriven   = False ,

  withInitEditor  = defaultWithInitEditor ,
  initialize      = initializeX11 ,
  finalize        = finalizeX11 ,
  displaySize     = const $ return ( 60, 24 ) ,
  drawDisplay     = drawDisplayX11 ,
  supplyEvent     = \xvars act -> doWhile_ $ getEventX11 xvars >>= act ,

  keybind         = defaultKeybind defaultCmdbind ,
  romode          = defaultRomode ,
  runAction       = runIOAction ,
  getReadOnlyFlag = defaultGetReadOnlyFlag

 }

main :: IO ()
main = runYavie myConfig

font, color :: String
font  = "Kochi Gothic-12:style=Regular"
color = "black"

type XVars =
  ( Display, Window, Visual, Colormap, XftDraw, XftFont, XIC, Atom, IORef String )

initializeX11 :: IO XVars
initializeX11 = do

    inbuf  <- newIORef ""

    ret    <- setLocale LC_CTYPE Nothing
    case ret of
	 Nothing -> putStrLn "Can't set locale." >> exitFailure
	 Just r  -> print r
    sl     <- supportsLocale
    unless sl $ putStrLn "Current locale is notSupported." >> exitFailure
    _      <- setLocaleModifiers ""

    dpy    <- openDisplay ""
    delWin <- internAtom dpy "WM_DELETE_WINDOW" True
    let scr      = defaultScreen dpy
        black    = blackPixel dpy scr
        white    = whitePixel dpy scr
        scrN     = defaultScreenOfDisplay dpy
        visual   = defaultVisual dpy scr
        colormap = defaultColormap dpy scr
    rootWin <- rootWindow dpy scr
    win     <- createSimpleWindow dpy rootWin 0 0 100 100 1 black white
    setWMProtocols dpy win [ delWin ]
    im      <- openIM dpy Nothing Nothing Nothing
    ic      <- createIC im [ XIMPreeditNothing, XIMStatusNothing ] win
    fevent  <- getICValue ic "filterEvents"
    xftDraw <- xftDrawCreate dpy win visual colormap
    xftFont <- xftFontOpen dpy scrN font
    mapWindow dpy win
    selectInput dpy win $ keyPressMask .|. exposureMask .|. fevent
    let xvars = ( dpy, win, visual, colormap, xftDraw, xftFont, ic, delWin, inbuf )

    return xvars

finalizeX11 :: XVars -> IO ()
finalizeX11 ( dpy, _, _, _, _, xftFont, _, _, _ ) = do
    xftFontClose dpy xftFont
    closeDisplay dpy

nextNotFilteredEvent :: Display -> XEventPtr -> IO ()
nextNotFilteredEvent dpy e = do
  nextEvent dpy e
  filtOut <- filterEvent e 0
  when filtOut $ nextNotFilteredEvent dpy e

evpToEvent :: ( Convertible CInt a, Eq a ) =>
  IORef String -> XIC -> a -> XEventPtr -> IO Yavie.Keybind.Event
evpToEvent inbuf ic delWin ep = do
    ev <- getEvent ep
    case ev of
      ExposeEvent {} -> do
        getCurrentTime >>= writeIORef preTime . addUTCTime (-4)
        return EvExpose
      KeyEvent {} -> do
        ( mstr, mks ) <- utf8LookupString ic ep
        let ch  = maybe ' ' head mstr
            ks  = fromMaybe xK_VoidSymbol mks
            key = case ks of
                       _ | ks == xK_Return   -> KEnter
                         | ks == xK_Escape   -> KEsc
                         | ks == xK_Shift_L  -> KUp
                         | ks == xK_Shift_R  -> KUp
                         | otherwise         -> KASCII ch
        writeIORef inbuf $ maybe "" tail mstr
        return $ EvKey key [ ]
      ClientMessageEvent {} ->
        if getClientMessageAtom ev == delWin
           then exitFailure
           else return $ EvKey KEsc [ ] 
      _ -> error "not yet implemented"

getEventX11 :: XVars -> IO Yavie.Keybind.Event
getEventX11 ( dpy, _, _, _, _, _, ic, delWin, inbuf ) =
  getKeyEvent inbuf dpy ic delWin

getKeyEvent :: ( Convertible CInt a, Eq a ) =>
  IORef String -> Display -> XIC -> a -> IO Yavie.Keybind.Event
getKeyEvent inbuf dpy ic delWin = allocaXEvent $ \e -> do
  ib <- readIORef inbuf
  case ib of
    c : _  -> do
      modifyIORef inbuf tail
      return $ EvKey ( KASCII c ) [ ]
    _ -> do
    nextNotFilteredEvent dpy e
    evpToEvent inbuf ic delWin e

getClientMessageAtom :: Convertible CInt a => Graphics.X11.Xlib.Extras.Event -> a
getClientMessageAtom = convert . head . ev_data

preMon :: IORef [ a ]
preMon = unsafePerformIO $ newIORef [ ]
preTime :: IORef UTCTime
preTime = unsafePerformIO $ getCurrentTime >>= newIORef . addUTCTime (-1)



drawDisplayX11 :: XVars -> IO ( Editor c ) -> IO ()
drawDisplayX11 xvars@( dpy, win, _, _, _, _, _, _, _ ) datForDpy = do
  dl <- datForDpy
  let im   = isBoxCursor dl
      ( cx, cy ) = cursorPosOfDpy dl
      lns  = displayLines dl
      ln   = lns !! cy
      bc   = if im then "[" else "|"
      ac   = if im then "]"  else ""
      ch   = if cx < 0 || cx >= length ln  then ' ' else ln !! cx
      nlns = take cy lns ++
             [ take cx ln ++ bc ++ [ ch ] ++ ac ++ drop ( cx + 1 ) ln ] ++
             drop ( cy + 1 ) lns
  pmon <- readIORef preMon
  tnow <- getCurrentTime
  tpre <- readIORef preTime
  let dt = diffUTCTime tnow tpre
  when ( pmon /= nlns && dt > 0.05 ) $ do
    writeIORef preMon nlns
    writeIORef preTime tnow
    clearWindow dpy win
    zipWithM_ ( putStrX xvars color ( 0 :: Int ) ) [ ( 0 :: Int) .. ]  nlns

putStrX :: ( Integral a, Integral b ) =>
  XVars -> String -> a -> b -> String -> IO ()
putStrX (dpy,_,visual,colormap,xftDraw,xftFont,_,_,_) col x y str =
  withXftColorName dpy visual colormap col $ \clr ->
    xftDrawString xftDraw clr xftFont ( 12 + 13 * x `div` 2 ) ( 12 + 15 * y ) str