{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main where

import Control.Applicative
import Control.Concurrent
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

import GHC.Stats (getGCStats)

import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer

import Buffer
import Process
import Scanner (scan, runScanner, toChar)


data VTConfig = VTConfig
    { withOutput :: IO () -> IO ()
    }

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

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

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

  let st = VTState
          { mode = InsertMode
          , buffer = ("", "")
          , processCount = 0
          }

  lockRef <- newMVar ()
  qRef <- newIORef st
  let _putState = writeIORef qRef -- TODO atomicModifyIORef (?)
      _getState = readIORef qRef
      _withOutput a = do
          q <- _getState
          withMVar lockRef $ \ _ -> do
              clearLine
              a
              renderInputLine (mode q) (buffer q)
              hFlush stdout

  let cf = VTConfig
            { withOutput = _withOutput
            }

  -- render initial input line
  _withOutput $ return ()

  forkIO $ dateThread _withOutput 1000000

  uiThread cf _putState _getState


dateThread :: (IO () -> IO ()) -> Int -> IO ()
dateThread _withOutput delay = forever $ do
    t <- liftIO getCurrentTime
    _withOutput $
      putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t
    threadDelay delay


uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO ()
uiThread cf putState getState = forever $ do
    q0 <- getState


    _ <- hLookAhead stdin -- wait for input
    --t0 <- getCurrentTime
    -- ((res, s), _) <- runScanner scan
    ((_, s), _) <- runScanner scan
    --t1 <- getCurrentTime
    --putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++
    --            (show $ diffUTCTime t1 t0)
    --            ++ ": \"\ESC[35m" ++ (concat $ map (colorize . toChar) s)
    --            ++ "\ESC[m\""
    --case res of
    --    Left msg -> putStrLn $ "  error: " ++ msg
    --    Right _ -> return ()

    -- TODO don't leak C
    let cmd = getCommand (mode q0) (map toChar s)

    --withOutput cf $ do
    --    putStrLn $ show cmd

    ((_, lns), q1) <- runVT cf q0 (execCommand cmd)

    -- TODO only putState if it has changed (?)
    putState q1

    -- XXX dummy for following legacy code
    let eitCmd = Right cmd

    let mbErr = case eitCmd of
                  Left err -> Just err
                  Right c ->
                      -- TODO move this to execCommand / throwError
                      case c of
                        MotionCommand motion | buffer q0 == buffer q1 ->
                            Just (OtherError $ "motion failed: " ++ show motion)
                        _ ->
                            Nothing

    withOutput cf $ do
        forM_ lns putStrLn

        case mbErr of
          Just err -> ringBell >> putStrLn (prettyError err)
          Nothing -> return ()

        --when (mode st /= mode st') $ do
        --    putStrLn $ "change mode: " ++ (show $ mode st')



data Command
  = AlertBadInput String
  | InsertString String
  | KillLastWord
  | KillLastChar
  | KillNextChar
  | ExecuteInputBuffer
  | MotionCommand LeftRightMotion
  | ChangeMode Mode
  -- TODO Move Count Motion
  --      Delete Count Register Motion
  --      etc.
  | Combine Command Command
  | Nop
  | RingBell

instance Monoid Command where
    mempty = Nop
    mappend = Combine



data ExecError
  = UnhandledInputError String
  | OtherError String

instance Error ExecError where
  noMsg = OtherError "something went wrong"

prettyError :: ExecError -> String
prettyError e = rec e
  where
    color cc s = "\x1b[" ++ cc ++ "m" ++ s ++ "\x1b[m"

    rec (UnhandledInputError s) =
      color "31" $ "unhandled input: <" ++ (pp "31;1" s) ++ "\x1b[;31m>"

    rec (OtherError s) =
      color "31" $ "error: " ++ s

    -- TODO cc is ColorCode
    pp cc = concat . map (pp1 cc)
    pp1 cc c
      | isPrint c = [c]
      | otherwise = specialChar cc $
        case c of
          '\x1b' -> "^["
          _ -> charToCode c
    specialChar cc s = "\x1b[1;35m" ++ s ++ "\x1b[;" ++ cc ++ "m"




modifyBuffer :: (Buffer -> Buffer) -> VT ()
modifyBuffer f =
    modify $ \st -> st { buffer = f (buffer st) }



newtype VT a = VT
    (ReaderT VTConfig
        (ErrorT ExecError
            (WriterT [String]
                (StateT VTState IO
        )))
        a)
  deriving
    ( Applicative
    , Functor
    , Monad
    , MonadError ExecError
    , MonadIO
    , MonadReader VTConfig
    , MonadState VTState
    , MonadWriter [String]
    )

runVT ::
    VTConfig -> VTState -> VT a -> IO ((Either ExecError a, [String]), VTState)

runVT cf st (VT a) =
    runStateT (runWriterT (runErrorT (runReaderT a cf))) st



insertString :: String -> Buffer -> Buffer
insertString s (ls, rs) = (ls ++ s, rs)


execCommand :: Command -> VT ()

execCommand (MotionCommand x) = do
    modifyBuffer (move x)
    -- TODO apply mode constraints somewhere else
    q <- get
    when (mode q == NormalMode) $
      when (null $ snd $ buffer q) $
        modifyBuffer (gotoLeft 1)

execCommand (ChangeMode m) =
    modify $ \ q -> q { mode = m }

execCommand (InsertString s) =
    modifyBuffer (insertString s)

execCommand ExecuteInputBuffer = do

    ---- XXX hack to replace empty command line
    --gets (null . showBuffer . buffer) >>= flip when
    --    (modify $ \q -> q { buffer = ("!","") })

    st <- get

    case showBuffer (buffer st) of
      ":s" -> do
          s <- liftIO getGCStats
          tell [ show s ]
      '!' : cmdline -> do
          --tell [ "spawn: " ++ cmdline ]
          -- "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ]
          -- TODO register process
          i <- state $ \ q ->
              let i = processCount q + 1
              in (i, q { processCount = i })
          cf <- ask
          liftIO $ forkIO $ spawn i (withOutput cf) cmdline
          return ()
      "" -> do
          liftIO ringBell
      s -> do
          tell [ "input: <" ++ (concat $ map (reform 32) s) ++ ">" ]

    modifyBuffer (const emptyBuffer)

execCommand KillNextChar = do
    get >>= flip (when . null . snd . buffer)
                 (throwError $ OtherError "nothing to kill right")
    modifyBuffer $ \(lhs, _:rhs') -> (lhs, rhs')

execCommand KillLastChar = do
    get >>= flip (when . null . fst . buffer)
                 (throwError $ OtherError "nothing to kill left")
    modifyBuffer $ \(lhs, rhs) -> (init lhs, rhs)

execCommand KillLastWord = do
    get >>= flip (when . null . fst . buffer)
                 (throwError $ OtherError "nothing to kill left")
    modifyBuffer $
      \(lhs, rhs) -> (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs)

execCommand (AlertBadInput s) =
    throwError (UnhandledInputError s)

execCommand (Combine c1 c2) = do
    cf <- ask
    q0 <- get

    ((eSt1, lines1), q1) <- liftIO $ runVT cf q0 (execCommand c1)

    -- TODO "stack trace"
    whenLeft eSt1 throwError

    ((eSt2, lines2), q2) <- liftIO $ runVT cf q1 (execCommand c2)

    -- TODO "stack trace"
    whenLeft eSt2 throwError

    tell lines1
    tell lines2

    put q2

execCommand Nop = return ()

execCommand RingBell = liftIO ringBell


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

normal :: Int -> String -> String
normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"

special :: Int -> String -> String
special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"



-- XXX assumes that the cursor is already at the (cleared) input line
renderInputLine :: Mode -> Buffer -> IO ()
renderInputLine m (lhs, rhs) = do
    clearLine -- TODO this is required for drawing the mode on the right side
    saveCursor
    moveCursorRight 1024
    moveCursorLeft (length (show m) - 1)
    putStr $ "\x1b[1;30m" ++ show m ++ "\x1b[m"
    unsaveCursor

    let promptString = case m of
                        NormalMode -> "\x1b[33;1m@\x1b[m "
                        InsertMode -> "> "
                        VerbatimMode -> "\x1b[34;1m^\x1b[m "

    putStr $ promptString ++ pp lhs ++ pp rhs
    moveCursorLeft (length $ ppVis rhs)
  where
    pp = concat . map reform'

    -- TODO unify reform and reform'
    reform' c =
      if isPrint c
        then [c]
        else
          "\x1b[35m" ++ (
            case ord c of
              27 -> "^["
              _ -> charToCode c
          ) ++ "\x1b[m"

    ppVis = concat . map reformVis
    reformVis c =
      if isPrint c
        then [c]
        else
            case ord c of
              27 -> "^["
              _ -> charToCode c






clearLine :: IO ()
clearLine =
    putStr "\x1b[2K" >>
    moveCursorLeft 1024


ringBell :: IO ()
ringBell = putStr "\x07" -- BEL '\a'


saveCursor :: IO ()
saveCursor = putStr "\x1b[s"

unsaveCursor :: IO ()
unsaveCursor = putStr "\x1b[u"


moveCursorLeft :: Int -> IO ()
moveCursorLeft 0 = return ()
moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"


moveCursorRight :: Int -> IO ()
moveCursorRight 0 = return ()
moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"


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



nmap :: Keymap
nmap =
  [ ("i", ChangeMode InsertMode)
  , ("a", ChangeMode InsertMode <> MotionCommand (GotoRight 1))
  , ("I", ChangeMode InsertMode <> MotionCommand GotoFirstChar)
  , ("A", ChangeMode InsertMode <> MotionCommand GotoEndOfLine)
  , ("0", MotionCommand GotoFirstChar)
  , ("$", MotionCommand GotoEndOfLine)
  , ("h", MotionCommand $ GotoLeft 1)
  , ("l", MotionCommand $ GotoRight 1)
  , ("b", MotionCommand $ WordsBackward 1)
  , ("w", MotionCommand $ WordsForward 1)
  , ("\x1b[C", MotionCommand $ GotoRight 1)
  , ("\x1b[D", MotionCommand $ GotoLeft 1)
  , ("\x0a", ExecuteInputBuffer <> ChangeMode InsertMode)
  , ("\x1b", RingBell) -- TODO cancel any unfinished commands
  ]


imap :: Keymap
imap =
  [ ("\x1b", ChangeMode NormalMode <> MotionCommand (GotoLeft 1))
  , ("\x01", MotionCommand GotoFirstChar)
  , ("\x05", MotionCommand GotoEndOfLine)
  , ("\x1b[3~", KillNextChar)
  , ("\x1b[C", MotionCommand $ GotoRight 1)
  , ("\x1b[D", MotionCommand $ GotoLeft 1)
  , ("\x16", ChangeMode VerbatimMode) -- ^V
  , ("\x17", KillLastWord) -- ^W
  , ("\x0a", ExecuteInputBuffer)
  , ("\x7f", KillLastChar) -- Delete
  , ("\x08", KillLastChar) -- BackSpace
  , ("\x1bOc", MotionCommand $ WordsForward 1)
  , ("\x1bOd", MotionCommand $ WordsBackward 1)
  ]


type Keymap = [(String, Command)]

data Mode
  = InsertMode
  | NormalMode
  | VerbatimMode
  deriving (Eq)

instance  Show Mode  where
  show NormalMode = "normal"
  show InsertMode = "insert"
  show VerbatimMode = "verbatim"


getCommand :: Mode -> String -> Command
getCommand InsertMode s = maybe (InsertString s) id $ lookup s imap
getCommand NormalMode s = maybe (AlertBadInput s) id $ lookup s nmap
getCommand VerbatimMode s = InsertString s <> ChangeMode InsertMode


-- TODO Control.Monad.whenLeft
whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
whenLeft (Left x) f = f x
whenLeft _ _ = return ()