path: root/Main-kaputt-mit-mtl.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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.Signal
--import Control.Monad.Trans.Class (lift)
--import Control.Monad.IO.Class (liftIO, MonadIO)
--import Control.Monad.Trans.State.Lazy
import Control.Monad.State
import Control.Monad.Reader
import Data.Typeable
import Control.Applicative


newtype VT a = VT (StateT VTState IO a)
    deriving (Functor, Monad, MonadIO, MonadState VTState)


instance Applicative VT where
    pure = return
    (<*>) = ap


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

runVT :: VTState -> VT a -> IO (a, VTState)
runVT st (VT a) = runStateT a st




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

  let st = VTState
        { mode = NormalMode nmap
        , buffer = lock
        }

  forkIO $ runVT st (dateThread 1000000 lock) >> return ()
  runVT st uiThread

  return ()


dateThread :: Int -> MVar Buffer -> VT ()
dateThread delay lock = forever $ do
    t <- liftIO getCurrentTime
    liftIO $ withMVar lock $ \ buf -> do
      putLine $ formatTime defaultTimeLocale rfc822DateFormat t 
      renderInputLine buf
      hFlush stdout
    liftIO $ threadDelay delay
 

--uiThread :: MVar Buffer -> VT ()
--uiThread lock = do
--    c <- liftIO $ getCommand mode
--uiThread :: mvar buffer -> vt ()
--uiThread lock = do
uiThread :: VT ()
uiThread = forever $ do
    st <- get
    let m = mode st
    c <- liftIO $ getCommand m
    b <- liftIO $ readMVar (buffer st)
    execCommand c b
    --mbMode <- liftIO $ modifyMVar (buffer st) (execCommand c)
    --case mbMode of
    --    Nothing -> return ()
    --    Just mode' -> do
    --        put $ st { mode = mode' }


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 :: Buffer -> VT ()
finishCommand buf = do
    b <- gets buffer
    liftIO $ do
        clearLine
        renderInputLine buf
        hFlush stdout
        putMVar b buf
    --modify $ \ st -> st { buffer = buf }
    --return (buf, Nothing)

--finishCommandChangeMode :: Buffer -> Mode -> IO (Buffer, Maybe Mode)
finishCommandChangeMode :: Buffer -> Mode -> VT ()
finishCommandChangeMode buf mode = do
    b <- gets buffer
    liftIO $ do
        clearLine
        putStrLn $ "change mode: " ++ (show mode)
        renderInputLine buf
        hFlush stdout
        putMVar b buf
    --return (buf, Just mode)
    --modify $ \ st -> st { buffer = buf }


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

execCommand GotoBOL (lhs, rhs) =
    finishCommand ("", lhs ++ rhs)

execCommand GotoEOL (lhs, rhs) =
    finishCommand (lhs ++ rhs, "")

execCommand MoveCursorLeft buf@(lhs@(_:_),rhs) = do
    finishCommand (init lhs, last lhs : rhs)

execCommand MoveCursorRight (lhs,rhs@(_:_)) = do
    finishCommand (lhs ++ [head rhs], tail rhs)

execCommand (InsertChar c) (lhs,rhs) = do
    finishCommand (lhs ++ [c], rhs)

execCommand (InsertCharThenChangeMode c m) (lhs, rhs) = do
    finishCommandChangeMode (lhs ++ [c], rhs) m

execCommand InsertNextCharVerbatim buf = do
    finishCommandChangeMode buf VerbatimMode

execCommand ExecuteInputBuffer (lhs,rhs) = do
    liftIO $ putLine $ "input: <" ++ (concat $ map (reform 32) $ lhs ++ rhs) ++ ">"
    finishCommand emptyBuffer

execCommand KillNextChar buf@(lhs,_:rhs') = do
    finishCommand (lhs, rhs')

execCommand KillLastChar (lhs@(_:_),rhs) = do
    finishCommand (init lhs, rhs)

execCommand KillLastWord (lhs@(_:_),rhs) = do
    finishCommand (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs)

execCommand (AlertBadInput s) buf@(lhs,rhs) = do
    liftIO $ putLine $ "unhandled input: <" ++ (concat $ map (reform 31) s) ++ ">"
    finishCommand buf

execCommand (UnboundSequence s n) buf@(lhs,rhs) = do
    liftIO $ putLine $ "unbound sequence: <" ++ (concat $ map (reform 31) s) ++ "> "
              ++ (special 31 n)
    finishCommand buf

execCommand _ buf = do
    liftIO $ do
        ringBell
        hFlush stdout
    --return (buf, Nothing)




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)