{-# OPTIONS_GHC -fffi #-}
{-# CFILES gwinsz.c #-}
module Graphics.Vty.Cursor
    ( TermState, putch, move, initTerm, clrscr, getwinsize, beep, flush,
      setCursorInvis, setCursorVis ) where

import Foreign.C.Types (CLong)

import System.IO( stdin, stdout, stderr, hGetChar, hPutStrLn, hFlush )

import Data.Maybe( mapMaybe )
import Data.List( inits )
import qualified Data.Map as M( fromList, lookup )
import qualified Data.Set as S( fromList, member )

import Control.Monad( when )

import Data.Bits( (.&.), shiftR )

import Control.Concurrent
import System.Posix.Signals.Exts
import System.Posix.Signals
import System.Posix.Terminal

import qualified UTF8

import Graphics.Vty.Types

--import GHC.Conc (labelThread)
threadName :: String -> IO ()
--threadName str = myThreadId >>= flip labelThread str
threadName _str = return ()

data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char]

-- | An object representing the current state of the terminal.
data TermState = TS !Int !Int !Attr

-- | Set up the terminal, and create an object representing the initial state.
-- Also returns a function which reads key events, and a function for shutting
-- down the terminal access.
initTerm :: IO (TermState, IO Event, IO ())
initTerm = do threadName "main-csr"
              kchan <- newEmptyMVar
              kmv <- newEmptyMVar
              oattr <- getTerminalAttributes 0
              let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts,
                                                   EnableEcho, ProcessInput]
              setTerminalAttributes 0 nattr Immediately
              iothr <- forkIO $ iothread kmv kchan
              let pokeIO = (Catch $ do threadName "winch|cont"
                                       (x,y) <- getwinsize_
                                       tryPutMVar kmv '\xFFFD'
                                       setTerminalAttributes 0 nattr Immediately
                                       putMVar kchan (EvResize x y))
              installHandler windowChange pokeIO Nothing
              installHandler continueProcess pokeIO Nothing
              putStr reset
              let uninit = do (sx,sy) <- getwinsize_
                              killThread iothr
                              installHandler windowChange Ignore Nothing
                              installHandler continueProcess Ignore Nothing
                              setTerminalAttributes 0 oattr Immediately
                              putStr (endterm sx sy)
                              hFlush stdout
              return (TS 0 0 attr, takeMVar kchan, uninit)

iothread :: MVar Char -> MVar Event -> IO ()
iothread kmv chn = threadName "kbd" >> loop [] where
    loop kb = case (classify kb) of
                Prefix       -> do ch <- getInput (kb == "")
                                   loop (kb ++ [ch])
                Invalid      -> loop ""
                MisPfx k m s -> putMVar chn (EvKey k m) >> loop s
                Valid k m    -> putMVar chn (EvKey k m) >> loop ""
    getInput wf = do t1 <- forkIO $ threadName "getc" >> hGetChar stdin >>= putMVar kmv
                     t2 <- forkIO $ threadName "sleep" >> if wf then return () else
                                        threadDelay 50000 >> putMVar kmv '\xFFFE'
                     ch <- takeMVar kmv
                     mapM_ killThread [t1,t2]
                     return ch

-- | Force sent commands to be respected.
flush :: TermState -> IO TermState
flush ts = hFlush stdout >> return ts

-- | Move the cursor to (x,y); sx is the current width of the screen.
-- (this is a bit of a hack, forcing clients to cache that data)
move :: Int -> Int -> Int -> TermState -> IO TermState
move sx x y (TS ox oy at) = do putStr $ movcsr y oy x ox sx
                               return (TS x y at)

-- | Put a (char,attr) at the current cursor position.
putch :: (Char,Attr) -> TermState -> IO TermState
putch (ch,att) (TS ox oy oat) = do when (att /= oat) $ putStr (chgatt att)
		                   tputchar ch
                                   return (TS (ox+1) oy att)

-- | Reset the screen.
clrscr :: TermState -> IO TermState
clrscr _ts = do putStr reset
                return (TS 0 0 attr)

-- | Make the cursor invisible.
setCursorInvis :: TermState -> IO TermState
setCursorInvis ts = putStr civis >> return ts

-- | Make the cursor visible.
setCursorVis :: TermState -> IO TermState
setCursorVis ts = putStr cvis >> return ts
-- ANSI specific bits
chgatt :: Attr -> [Char]
chgatt (Attr bf)
      = "\ESC[0" ++ ";3" ++ show (bf .&. 0xFF) ++ ";4" ++ show ((bf `shiftR` 8) .&. 0xFF) ++ 0x10000 ? 1 ++
        0x20000 ? 5 ++ 0x40000 ? 7 ++ 0x80000 ? 2 ++ 0x100000 ? 4 ++ "m"
    where
      (?) :: Int -> Int -> [Char]
      field ? x | bf .&. field == 0 = ""
                | otherwise         = ';' : show x

tputchar :: Char -> IO ()
tputchar ch = do when ((ch < ' ') || (ch == '\DEL')) $
                      hPutStrLn stderr "YIKES: tried to put nongraphic"
                 mapM_ (putChar . toEnum . fromIntegral) $ UTF8.encodeOne ch
-- we always use absolute motion between lines to work around diffs
movcsr :: Int -> Int -> Int -> Int -> Int -> [Char]
movcsr y oy x ox wid
  | y /= oy || ox == wid = ("\ESC[" ++ (show (y+1)) ++ ';' : (show (x+1)) ++ "H")
  | x == ox              = ""
  | x == (ox + 1)        = ("\ESC[C")
  | x > ox               = ("\ESC[" ++ (show (x - ox)) ++ "C")
  | otherwise            = ("\ESC[" ++ (show (ox - x)) ++ "D")

compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass
compile lst = cl' where
    lst' = concat lst
    pfx = S.fromList $ concatMap (init . inits . fst) $ lst'
    mlst = M.fromList lst'
    cl' "\xFFFD" = Invalid ; cl' "\xFFFE" = Invalid
    cl' str = case S.member str pfx of
                True -> Prefix
                False -> case M.lookup str mlst of
                           Just (k,m) -> Valid k m
                           Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of
                                        (s,(k,m)) -> MisPfx k m (drop (length s) str)
classify :: [Char] -> KClass
classify = compile $
           [ let k c s = ("\ESC["++c,(s,[])) in
             [ k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft, k "G" KNP5, k "P" KPause ],
             let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [1::Int ..6] [KHome,KIns,KDel,KEnd,KPageUp,KPageDown],
             [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],
             [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],
             let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in
             concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],
             [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],
             [ ([toEnum x],(KASCII y,[MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],
             [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],
             [ ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])) , ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),
               ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] ]

foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong
getwinsize_ :: IO (Int,Int)
getwinsize_ = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
                 return (fromIntegral b, fromIntegral a)
getwinsize :: TermState -> IO ((Int,Int), TermState)
getwinsize ts = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
                   return ((fromIntegral b, fromIntegral a), ts)

cvis, civis, reset :: [Char]

reset = "\ESCc\ESC%G\ESC[1;1H\ESC[2J"
-- | Make the terminal beep.
beep :: IO ()
beep = putStr "\BEL" ; cvis = "\ESC[?25h" ; civis = "\ESC[?25l"
endterm :: Int -> Int -> [Char]
endterm sx sy = movcsr (sy-1) (-1) 0 (-1) sx ++ "\ESC[0;39;49m\ESC%@\CR\ESC[?25h\ESC[K"