{-# OPTIONS_GHC -Wall #-}
module Graphics.Vty.LLInput
    ( Key(..), Modifier(..), Button(..), Event(..), initTermInput ) where

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.Concurrent
import System.Posix.Signals.Exts
import System.Posix.Signals
import System.Posix.Terminal

-- |Representations of non-modifier keys.
data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns
         | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu
         | KLeft | KDown | KRight | KEnter deriving (Eq,Show,Ord)
-- |Modifier keys.  Key codes are interpreted such that users are more likely to
-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will
-- generally correspond to the physical Alt key.
data Modifier = MShift | MCtrl | MMeta | MAlt deriving (Eq,Show,Ord)
-- |Mouse buttons.  Not yet used.
data Button = BLeft | BMiddle | BRight deriving (Eq,Show,Ord)
-- |Generic events.
data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier]
           | EvResize Int Int deriving (Eq,Show,Ord)

--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]

-- | Set up the terminal for input.  Returns a function which reads key
-- events, and a function for shutting down the terminal access.
initTermInput :: IO (IO Event, IO ())
initTermInput = do
  threadName "main"
  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"
                           tryPutMVar kmv '\xFFFD'
                           let e = error "(getsize in input layer)"
                           setTerminalAttributes 0 nattr Immediately
                           putMVar kchan (EvResize e e))
  installHandler windowChange pokeIO Nothing
  installHandler continueProcess pokeIO Nothing
  let uninit = do killThread iothr
                  installHandler windowChange Ignore Nothing
                  installHandler continueProcess Ignore Nothing
                  setTerminalAttributes 0 oattr Immediately
  return (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" >> getChar >>= 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

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)

-- ANSI specific bits

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,[])) ] ]