From bc8d3ab9d134baa4517757f6f7ab80857361bd65 Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Sun, 27 Jul 2014 11:02:45 +0200
Subject: initial commit

---
 Main.hs | 400 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 400 insertions(+)
 create mode 100644 Main.hs

(limited to 'Main.hs')

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
+        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)
+
-- 
cgit v1.2.3