path: root/Main.hs

{-# 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

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

    ((eitCmd, lns), q1) <- runVT cf q0 $ do
        c <- getCommand (mode q0)
        execCommand c
        return c

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

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

    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 -> VT Command
getCommand InsertMode = getCommandXXX imap InsertString
getCommand NormalMode = getCommandXXX nmap AlertBadInput
getCommand VerbatimMode = verbatimKeymap


-- TODO refactor me please^_^
getCommandXXX :: Keymap -> (String -> Command) -> VT Command
getCommandXXX keymap defCmd = do

    -- wait for the first character
    _ <- liftIO $ hLookAhead stdin

    bufRef <- liftIO $ newIORef ""
    candRef <- liftIO $ newIORef Nothing
    cmdRef <- liftIO $ newEmptyMVar -- :: MVar (Maybe (String -> Command))

    -- TODO ensure that this thread dies eventually
    --forkIO $ rec "" keymap cmdRef candRef
    getCharThreadId <-
        --forkFinally (rec keymap cmdRef candRef bufRef)
        --            (\_ -> putStrLn "input terminated")
        liftIO $ forkIO $ do
          rec keymap cmdRef candRef bufRef

    watchDogThreadId <-
        liftIO $ forkIO $ do
          --putStrLn "watchdog activated"
          threadDelay $ 1000 * 50 -- 50ms
          --putStrLn "watchdog timeout"
          killThread getCharThreadId
          --putStrLn "watchdog killed getCharThread"
          putMVar cmdRef Nothing -- continue main thread

    mbCmd <- liftIO $ takeMVar cmdRef

    liftIO $ killThread watchDogThreadId

    cmd <- case mbCmd of
        Just cmd -> return cmd
        Nothing -> do
            mbCmd2 <- liftIO $ readIORef candRef
            case mbCmd2 of
                Just cmd2 -> return cmd2
                Nothing -> return defCmd

    s <- liftIO $ readIORef bufRef

    --clearLine
    --putStrLn $ "\x1b[35;1m" ++ (show s) ++ " -> " ++ (show $ cmd s) ++ "\x1b[m"
    return $ cmd s

  where
    rec :: Keymap
        -> MVar (Maybe (String -> Command))
        -> IORef (Maybe (String -> Command))
        -> IORef String
        -> IO ()
    rec km cmdRef candRef bufRef = do
        c <- getChar
        -- TODO s <- atomicModifyIORef bufRef $ \s -> let s' = s++[c] in (s,s)
        olds <- readIORef bufRef
        let s = olds ++ [c]
        writeIORef bufRef s

        let km' = map (\(str,cmd) -> (tail str, cmd))
                $ filter ((==c) . head . fst) km

            -- direct and indirect candidates
            (dc, ic) = partition (null . fst) km'

        --clearLine
        --putStrLn $ " s: " ++ show s
        --putStrLn $ "ic: " ++ (show $ map snd ic)
        --putStrLn $ "dc: " ++ (show $ map snd dc)

        -- update candidate
        if length dc == 1
          then atomicWriteIORef candRef (Just $ const $ snd $ dc !! 0)
          else atomicWriteIORef candRef Nothing

        case length km' of
          0 -> do
            --return $ defCmd' (s ++ [c])
            cand <- readIORef candRef
            putMVar cmdRef cand
          1 ->
            let (rest, cmd) = km' !! 0
            in if null rest
                then do
                  --return $ cmd
                  -- TODO somehow give s?
                  putMVar cmdRef (Just $ const cmd)
                else do
                  --rec (s ++ [c]) ic defCmd'
                  rec ic cmdRef candRef bufRef
          _ -> do
            --rec (s ++ [c]) ic defCmd'
            rec ic cmdRef candRef bufRef



verbatimKeymap :: VT Command
verbatimKeymap = do
  c <- liftIO getChar
  return $ InsertString [c] <> ChangeMode InsertMode


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