initial commit

8 files changed, 1466 insertions, 0 deletions

diff --git a/Main-gut-ohne-transformers.hs b/Main-gut-ohne-transformers.hs
new file mode 100644
index 0000000..c4646ec
--- /dev/null
+++ b/Main-gut-ohne-transformers.hs
@@ -0,0 +1,340 @@
+{-# 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
+
+
+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 mode lock = do
+    c <- getCommand mode
+    mbMode <- modifyMVar lock (execCommand c)
+    case mbMode of
+        Nothing ->
+            uiThread mode lock
+        Just mode' -> 
+            uiThread mode' 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)
+
+
+
+execCommand :: Command -> Buffer -> IO (Buffer, Maybe Mode)
+
+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
+    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
+    putLine $ "unhandled input: <" ++ (concat $ map (reform 31) s) ++ ">"
+    finishCommand buf
+
+execCommand (UnboundSequence s n) buf@(lhs,rhs) = do
+    putLine $ "unbound sequence: <" ++ (concat $ map (reform 31) s) ++ "> "
+              ++ (special 31 n)
+    finishCommand buf
+
+execCommand _ buf = 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)
+
diff --git a/Main-kaputt-mit-mtl.hs b/Main-kaputt-mit-mtl.hs
new file mode 100644
index 0000000..0167b9f
--- /dev/null
+++ b/Main-kaputt-mit-mtl.hs
@@ -0,0 +1,396 @@
+{-# 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)
+
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..8f4ceb7
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,400 @@
+{-# 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