{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import Data.Char
import Data.IORef
import Data.List
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import Numeric (showIntAtBase)
import System.IO
import System.Locale (defaultTimeLocale, rfc822DateFormat)
--import System.Posix.Signals


data VTState = VTState
    { buffer :: Buffer
    , mode :: Mode
    }

emptyState = VTState emptyBuffer (NormalMode nmap)


type Buffer = (String, String)

emptyBuffer = ("", "")


main :: IO ()
main = do
  hSetEcho stdin False
  hSetBuffering stdin NoBuffering

  tid <- myThreadId

  -- WINCH
  -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing

  lock <- newMVar emptyBuffer

  renderInputLine emptyBuffer
  hFlush stdout

  forkIO $ (dateThread 1000000) lock
  uiThread (NormalMode nmap) lock


dateThread delay lock = forever $ do
    t <- getCurrentTime
    withMVar lock $ \ buf -> do
      putLine $ formatTime defaultTimeLocale rfc822DateFormat t 
      renderInputLine buf
      hFlush stdout
    threadDelay delay
 

uiThread mod lock = do
    c <- getCommand mod
    --mbMode <- modifyMVar lock (execCommand c)
    --case mbMode of
    --    Nothing ->
    --        uiThread mode lock
    --    Just mode' -> 
    --        uiThread mode' lock
    mod' <- modifyMVar lock $ \ buf -> do
        let st = VTState
                { mode = mod
                , buffer = buf
                }
        mbst' <- execCommand c st

        case mbst' of
          Nothing -> do
            ringBell
            hFlush stdout
            return (buf, mod)
          Just st' -> do
            clearLine
            when (show (mode st) /= show (mode st')) $ do
                putStrLn $ "change mode: " ++ (show $ mode st')
            renderInputLine (buffer st')
            hFlush stdout

            return (buffer st', mode st')

    uiThread mod' lock


data Command
  = AlertBadInput String
  | InsertChar Char
  | InsertNextCharVerbatim
  | InsertCharThenChangeMode Char Mode
  | MoveCursorRight
  | MoveCursorLeft
  | KillLastWord
  | KillLastChar
  | KillNextChar
  | ExecuteInputBuffer
  | UnboundSequence String String
  | GotoBOL
  | GotoEOL


--finishCommand :: Buffer -> IO (Buffer, Maybe Mode)
--finishCommand buf = do
--    clearLine
--    renderInputLine buf
--    hFlush stdout
--    return (buf, Nothing)
--
--finishCommandChangeMode :: Buffer -> Mode -> IO (Buffer, Maybe Mode)
--finishCommandChangeMode buf mode = do
--    clearLine
--    putStrLn $ "change mode: " ++ (show mode)
--    renderInputLine buf
--    hFlush stdout
--    return (buf, Just mode)

-- TODO execCommand :: Command -> VTState -> VTState

--execCommand :: Command -> Buffer -> IO (Buffer, Maybe Mode)


-- TODO instead of propagating Maybe to caller, use
--      something like Writer monad to generate bell
modifyBuffer :: (Buffer -> Maybe Buffer) -> VTState -> Maybe VTState
modifyBuffer f st =
  case f (buffer st) of
    Nothing -> Nothing
    Just b' -> Just st { buffer = b' }

-- TODO instance Show Buffer (w/newtype Buffer)

showBuffer :: Buffer -> String
showBuffer (lhs, rhs) = lhs ++ rhs


execCommand :: Command -> VTState -> IO (Maybe VTState)

execCommand GotoBOL q =
    return . modifyBuffer (\(lhs, rhs) -> Just ("", lhs ++ rhs)) $ q

execCommand GotoEOL q =
    return . modifyBuffer (\(lhs, rhs) -> Just (lhs ++ rhs, "")) $ q

execCommand MoveCursorLeft q =
    return . modifyBuffer (\(lhs, rhs) ->
      if null lhs then Nothing else Just (init lhs, last lhs : rhs)
                          ) $ q

execCommand MoveCursorRight q =
    return . modifyBuffer (\(lhs, rhs) ->
      if null lhs then Nothing else Just (lhs ++ [head rhs], tail rhs)
                          ) $ q

execCommand (InsertChar c) q =
    return . modifyBuffer (\(lhs, rhs) -> Just (lhs ++ [c], rhs)) $ q

execCommand (InsertCharThenChangeMode c m) q =
    execCommand (InsertChar c) q { mode = m }

execCommand InsertNextCharVerbatim q =
    return . modifyBuffer Just $ q { mode = VerbatimMode }

execCommand ExecuteInputBuffer q = do
    -- TODO Writer monad?
    putLine $ concat
      [ "input: <", concat $ map (reform 32) $ showBuffer . buffer $ q, ">"
      ]
    return . modifyBuffer (const $ Just emptyBuffer) $ q

execCommand KillNextChar q =
    return . modifyBuffer (\(lhs, _:rhs') -> Just (lhs, rhs')) $ q

execCommand KillLastChar q =
    return . modifyBuffer (\(lhs, rhs) ->
      if null lhs then Nothing else Just (init lhs, rhs)
                          ) $ q

execCommand KillLastWord q =
    return . modifyBuffer (\(lhs, rhs) ->
      if null lhs then Nothing
          else Just (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs)
                          ) $ q

execCommand (AlertBadInput s) q = do
    putLine $ "unhandled input: <" ++ (concat $ map (reform 31) s) ++ ">"
    return Nothing
    --return . Just $ q

execCommand (UnboundSequence s n) q = do
    putLine $ "unbound sequence: <" ++ (concat $ map (reform 31) s) ++ "> "
              ++ (special 31 n)
    --return . Just $ q
    return Nothing

--execCommand _ q = do
--    ringBell
--    hFlush stdout
--    return q



putLine s = do
    clearLine -- TODO this renders finishCommand's clearLine redundant
    putStrLn s



reform colorCode c =
    if isPrint c
      then normal colorCode [c]
      else
        special colorCode $
          case ord c of
            27 -> "^["
            _ -> charToCode c

normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"



-- XXX assumes that the cursor is already at the input line
renderInputLine :: Buffer -> IO ()
renderInputLine (lhs, rhs) = do
    --clearLine
    putStr $ "> " ++ pp lhs ++ pp rhs
    moveCursorLeft (length $ ppVis rhs)
    --hFlush stdout
  where
    pp = concat . map reform
    reform c =
      if isPrint c
        then [c]
        else
          "\x1b[35m" ++ (
            case ord c of
              27 -> "^["
              _ -> "\\" ++ show (ord c)
          ) ++ "\x1b[m"

    ppVis = concat . map reformVis
    reformVis c =
      if isPrint c
        then [c]
        else
            case ord c of
              27 -> "^["
              _ -> "\\" ++ show (ord c)






clearLine =
    putStr "\x1b[2K" >>
    moveCursorLeft 80


ringBell = putStr "\x07" -- BEL '\a'


moveCursorLeft 0 = return ()
moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"

moveCursorRight 0 = return ()
moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"

clearLineFromCursorRight = putStr "\x1b[0K"


-- TODO? charToCode c = "\\x" ++ showHex (ord c)
charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) ""





-- TODO pressing ESC, then F11 etc. is ugly
nmap =
  [ ("\x01", GotoBOL)
  , ("\x05", GotoEOL)
  , ("\x1b[3~", KillNextChar)
  , ("\x1b[C", MoveCursorRight)
  , ("\x1b[D", MoveCursorLeft)
  , ("\x16", InsertNextCharVerbatim) -- ^V
  , ("\x17", KillLastWord) -- ^W
  , ("\x0a", ExecuteInputBuffer)
  , ("\x7f", KillLastChar) -- Delete
  , ("\x08", KillLastChar) -- BackSpace
  ]
  ++ [unboundSequence "\x1b[2~" "<Insert>"]
  ++ [unboundSequence "\x1b[5~" "<Prior>"]    -- page up
  ++ [unboundSequence "\x1b[6~" "<Next>"]     -- page dn
  ++ [unboundSequence "\x1b[7~" "<Home>"]
  ++ [unboundSequence "\x1b[8~" "<End>"]
  ++ [unboundSequence "\x1b[2$" "<S-Insert>"]
  ++ [unboundSequence "\x1b[5$" "<S-Prior>"]    -- page up
  ++ [unboundSequence "\x1b[6$" "<S-Next>"]     -- page dn
  ++ [unboundSequence "\x1b[7$" "<S-Home>"]
  ++ [unboundSequence "\x1b[8$" "<S-End>"]
  ++ [unboundSequence "\x1b\x1b[2$" "<S-M-Insert>"]
  ++ [unboundSequence "\x1b\x1b[5$" "<S-M-Prior>"]    -- page up
  ++ [unboundSequence "\x1b\x1b[6$" "<S-M-Next>"]     -- page dn
  ++ [unboundSequence "\x1b\x1b[7$" "<S-M-Home>"]
  ++ [unboundSequence "\x1b\x1b[8$" "<S-M-End>"]
  ++ [unboundSequence "\x1b\x1b[A" "<M-Up>"]
  ++ [unboundSequence "\x1b\x1b[B" "<M-Down>"]
  ++ [unboundSequence "\x1b\x1b[C" "<M-Right>"]
  ++ [unboundSequence "\x1b\x1b[D" "<M-Left>"]
  ++ [unboundSequence "\x1b\x1b[a" "<S-M-Up>"]
  ++ [unboundSequence "\x1b\x1b[b" "<S-M-Down>"]
  ++ [unboundSequence "\x1b\x1b[c" "<S-M-Right>"]
  ++ [unboundSequence "\x1b\x1b[d" "<S-M-Left>"]
  ++ [unboundSequence "\x1b[a" "<S-Up>"]
  ++ [unboundSequence "\x1b[b" "<S-Down>"]
  ++ [unboundSequence "\x1b[c" "<S-Right>"]
  ++ [unboundSequence "\x1b[d" "<S-Left>"]
  ++ [unboundSequence "\x1bOa" "<C-Up>"]
  ++ [unboundSequence "\x1bOb" "<C-Down>"]
  ++ [unboundSequence "\x1bOc" "<C-Right>"]
  ++ [unboundSequence "\x1bOd" "<C-Left>"]
  ++ [unboundSequence "\x1b\x1bOa" "<C-M-Up>"]
  ++ [unboundSequence "\x1b\x1bOb" "<C-M-Down>"]
  ++ [unboundSequence "\x1b\x1bOc" "<C-M-Right>"]
  ++ [unboundSequence "\x1b\x1bOd" "<C-M-Left>"]
  ++ [unboundSequence "\x1b[11~" "<F1>"]
  ++ [unboundSequence "\x1b[12~" "<F2>"]
  ++ [unboundSequence "\x1b[13~" "<F3>"]
  ++ [unboundSequence "\x1b[14~" "<F4>"]
  ++ [unboundSequence "\x1b[15~" "<F5>"]
  ++ [unboundSequence "\x1b[17~" "<F6>"]
  ++ [unboundSequence "\x1b[18~" "<F7>"]
  ++ [unboundSequence "\x1b[19~" "<F8>"]
  ++ [unboundSequence "\x1b[20~" "<F9>"]
  ++ [unboundSequence "\x1b[21~" "<F10>"]
  ++ [unboundSequence "\x1b[23~" "<F11>"]
  ++ [unboundSequence "\x1b[24~" "<F12>"]

  ++ [unboundSequence "\x1b\x1b[2~" "<M-Insert>"]
  ++ [unboundSequence "\x1b\x1b[3~" "<M-Delete>"]
  ++ map (\ i -> unboundSequence ("\x1b\x1b[" ++ show i ++ "~")
                                 ("<M-F" ++ show i ++ ">"))
          [11..24]
  ++ [unboundSequence "\x1b\x7f" "<M-BackSpace>"]
  ++ [unboundSequence "\x1b\x0a" "<M-Return>"]


unboundSequence seq name =
  (seq, UnboundSequence seq name)


data Mode
  = NormalMode [(String, Command)]
  | VerbatimMode

instance  Show Mode  where
  show (NormalMode _) = "normal"
  show VerbatimMode = "verbatim"


getCommand :: Mode -> IO Command
getCommand (NormalMode map) = getMappedCommand map
getCommand VerbatimMode = verbatimKeymap


getMappedCommand :: [(String, Command)] -> IO Command
getMappedCommand xs = do
    c <- getChar
    if any (isPrefixOf [c] . fst) xs
      then rec [c]
      else
        if isPrint c
          then return $ InsertChar c
          else return $ AlertBadInput [c]
  where
    rec :: String -> IO Command
    rec s =
      case lookup s xs of
        Just c -> return c
        _ ->
          if any (isPrefixOf s . fst) xs
            then do
              c <- getChar
              rec $ s ++ [c]
            else
              return $ AlertBadInput s


verbatimKeymap :: IO Command
verbatimKeymap = do
  c <- getChar
  --return $ InsertCharThenChangeMode c defaultGetCommand
  return $ InsertCharThenChangeMode c (NormalMode nmap)