summaryrefslogtreecommitdiffstats
path: root/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Main.hs')
-rw-r--r--Main.hs400
1 files changed, 400 insertions, 0 deletions
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)
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-25 11:54:45 +0000