module Main where

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (forever)
import System.IO
import Data.IORef
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import System.Locale (defaultTimeLocale, rfc822DateFormat)
import Data.Char
import Data.List


data Config = Config

data State = State
  { promptString :: String
  , inputBuffer :: (String, String)
  , getCommand :: IO Command
  , outputLock :: MVar ()
  }

initState :: State
initState = State "> " ("", "") defaultGetCommand


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

  lock <- newMVar initState

  let q = State
        { promptString = "> "
        , inputBuffer = ("", "")
        , getCommand = defaultGetCommand
        , outputLock = lock
        }

  putStr (promptString q)

  forkIO $ dateThread q
  uiThread q


dateThread q = forever $ do
    t <- getCurrentTime
    withMVar (outputLock q) $ \ _ -> do
      clearLine
      putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t 
      putStr $ (promptString q) ++ lhs ++ rhs
      moveCursorLeft (length rhs)
      hFlush stdout
      return ()
    threadDelay 1000000


uiThread q = do
    c <- getCommand q
    modifyMVar_ (outputLock q) (execCommand c) >>= uiThread


data Command
  = AlertBadInput String
  | InsertChar Char
  | InsertNextCharVerbatim
  | MoveCursorRight
  | MoveCursorLeft
  | KillLastWord
  | KillLastChar
  | ExecuteInputBuffer


defaultGetCommand :: IO Command
defaultGetCommand = do
    c1 <- getChar
    case c1 of
      '\x1b' -> do
        c2 <- getChar
        case c2 of
          '[' -> do
            c3 <- getChar
            case c3 of
              'C' -> return MoveCursorRight
              'D' -> return MoveCursorLeft
              _ -> return $ AlertBadInput (c1:c2:c3:[])
          _ -> return $ AlertBadInput (c1:c2:[])
      _ ->
        if isPrint c1
          then return $ InsertChar c1
          else
            case ord c1 of
              22 -> return InsertNextCharVerbatim
              23 -> return KillLastWord
              10 -> return ExecuteInputBuffer
              127 -> return KillLastChar
              _ -> return $ AlertBadInput (c1:[])


execCommand :: String -> Command -> (String, String) -> IO (String, String)

execCommand MoveCursorLeft q@State{inputBuffer=([],_)} =
  cannotExecuteCommand q

execCommand MoveCursorLeft q@State{inputBuffer=(lhs,rhs)} = do
    clearLineFromCursorRight
    putStr rhs
    moveCursorLeft (length rhs + 1)
    hFlush stdout
    return q{inputBuffer=(init lhs, last lhs : rhs)}

execCommand MoveCursorRight q@State{inputBuffer=(_,[])} =
  cannotExecuteCommand q

execCommand MoveCursorRight q@State{inputBuffer=(lhs,rhs)} = do
    moveCursorRight 1
    hFlush stdout
    return q{inputBuffer=(lhs ++ [head rhs], tail rhs)}

execCommand (InsertChar c) q@State{inputBuffer=(lhs,rhs)} = do
    putChar c
    -- TODO rhs
    hFlush stdout
    return q{inputBuffer=(lhs ++ [c], rhs)}

--execCommand InsertNextCharVerbatim input = do
--    return input { keymap = verbatimKeymap }


execCommand ExecuteInputBuffer q@State{inputBuffer=(lhs,rhs)} = do
    clearLine
    putStrLn $ "input: <\x1b[32;1m" ++ lhs ++ rhs ++ "\x1b[m>"
    putStr (promptString q)
    hFlush stdout
    return q{inputBuffer=("","")}

execCommand KillLastChar q@State{inputBuffer=([],_)} =
  cannotExecuteCommand q

execCommand KillLastChar q@State{inputBuffer=(lhs,rhs)} = do
    moveCursorLeft 1
    clearLineFromCursorRight
    putStr rhs
    moveCursorLeft (length rhs)
    hFlush stdout
    return q{inputBuffer=(init lhs, rhs)}

execCommand KillLastWord q@State{inputBuffer=([],_)} =
  cannotExecuteCommand q

execCommand KillLastWord q@State{inputBuffer=(lhs,rhs)} = do
    let lhs' =
          dropWhileEnd (not . isSpace) $
          dropWhileEnd isSpace lhs
        killedCharCount = length lhs - length lhs'
    moveCursorLeft killedCharCount
    clearLineFromCursorRight
    putStr rhs
    moveCursorLeft (length rhs)
    hFlush stdout
    return q{inputBuffer=(lhs', rhs)}

execCommand (AlertBadInput s) q@State{inputBuffer=(lhs,rhs)} = do
    clearLine
    putStrLn $ "unhandled input: <" ++ (concat $ map reform s) ++ ">"
    putStr $ (promptString q) ++ lhs ++ rhs
    moveCursorLeft (length rhs)
    hFlush stdout
    return q
  where
    reform c =
      if isPrint c
        then "\x1b[31m" ++ [c] ++ "\x1b[m"
        else
          "\x1b[1;31m" ++ (
            case ord c of
              27 -> "^["
              _ -> "\\" ++ show (ord c)
          ) ++ "\x1b[m"


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



cannotExecuteCommand input = do
  ringBell
  hFlush stdout
  return input



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"