summaryrefslogtreecommitdiffstats
path: root/Main-kaputt-mit-mtl.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Main-kaputt-mit-mtl.hs')
-rw-r--r--Main-kaputt-mit-mtl.hs396
1 files changed, 396 insertions, 0 deletions
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)
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 06:51:47 +0000