summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Main-gut-ohne-transformers.hs340
-rw-r--r--Main-kaputt-mit-mtl.hs396
-rw-r--r--OldMain.hs206
-rw-r--r--defaultGetCommand.hs33
4 files changed, 0 insertions, 975 deletions
diff --git a/Main-gut-ohne-transformers.hs b/Main-gut-ohne-transformers.hs
deleted file mode 100644
index c4646ec..0000000
--- a/Main-gut-ohne-transformers.hs
+++ /dev/null
@@ -1,340 +0,0 @@
-{-# 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
deleted file mode 100644
index 0167b9f..0000000
--- a/Main-kaputt-mit-mtl.hs
+++ /dev/null
@@ -1,396 +0,0 @@
-{-# 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/OldMain.hs b/OldMain.hs
deleted file mode 100644
index 05fb955..0000000
--- a/OldMain.hs
+++ /dev/null
@@ -1,206 +0,0 @@
-module Main where
-
-import Control.Concurrent
-import Control.Concurrent.MVar
-import Control.Monad (forever)
-import System.IO
-import Data.IORef
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Format (formatTime)
-import System.Locale (defaultTimeLocale, rfc822DateFormat)
-import Data.Char
-import Data.List
-
-
-data Config = Config
-
-data State = State
- { promptString :: String
- , inputBuffer :: (String, String)
- , getCommand :: IO Command
- , outputLock :: MVar ()
- }
-
-initState :: State
-initState = State "> " ("", "") defaultGetCommand
-
-
-main :: IO ()
-main = do
- hSetEcho stdin False
- hSetBuffering stdin NoBuffering
-
- lock <- newMVar initState
-
- let q = State
- { promptString = "> "
- , inputBuffer = ("", "")
- , getCommand = defaultGetCommand
- , outputLock = lock
- }
-
- putStr (promptString q)
-
- forkIO $ dateThread q
- uiThread q
-
-
-dateThread q = forever $ do
- t <- getCurrentTime
- withMVar (outputLock q) $ \ _ -> do
- clearLine
- putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t
- putStr $ (promptString q) ++ lhs ++ rhs
- moveCursorLeft (length rhs)
- hFlush stdout
- return ()
- threadDelay 1000000
-
-
-uiThread q = do
- c <- getCommand q
- modifyMVar_ (outputLock q) (execCommand c) >>= uiThread
-
-
-data Command
- = AlertBadInput String
- | InsertChar Char
- | InsertNextCharVerbatim
- | MoveCursorRight
- | MoveCursorLeft
- | KillLastWord
- | KillLastChar
- | ExecuteInputBuffer
-
-
-defaultGetCommand :: IO Command
-defaultGetCommand = do
- c1 <- getChar
- case c1 of
- '\x1b' -> do
- c2 <- getChar
- case c2 of
- '[' -> do
- c3 <- getChar
- case c3 of
- 'C' -> return MoveCursorRight
- 'D' -> return MoveCursorLeft
- _ -> return $ AlertBadInput (c1:c2:c3:[])
- _ -> return $ AlertBadInput (c1:c2:[])
- _ ->
- if isPrint c1
- then return $ InsertChar c1
- else
- case ord c1 of
- 22 -> return InsertNextCharVerbatim
- 23 -> return KillLastWord
- 10 -> return ExecuteInputBuffer
- 127 -> return KillLastChar
- _ -> return $ AlertBadInput (c1:[])
-
-
-execCommand :: String -> Command -> (String, String) -> IO (String, String)
-
-execCommand MoveCursorLeft q@State{inputBuffer=([],_)} =
- cannotExecuteCommand q
-
-execCommand MoveCursorLeft q@State{inputBuffer=(lhs,rhs)} = do
- clearLineFromCursorRight
- putStr rhs
- moveCursorLeft (length rhs + 1)
- hFlush stdout
- return q{inputBuffer=(init lhs, last lhs : rhs)}
-
-execCommand MoveCursorRight q@State{inputBuffer=(_,[])} =
- cannotExecuteCommand q
-
-execCommand MoveCursorRight q@State{inputBuffer=(lhs,rhs)} = do
- moveCursorRight 1
- hFlush stdout
- return q{inputBuffer=(lhs ++ [head rhs], tail rhs)}
-
-execCommand (InsertChar c) q@State{inputBuffer=(lhs,rhs)} = do
- putChar c
- -- TODO rhs
- hFlush stdout
- return q{inputBuffer=(lhs ++ [c], rhs)}
-
---execCommand InsertNextCharVerbatim input = do
--- return input { keymap = verbatimKeymap }
-
-
-execCommand ExecuteInputBuffer q@State{inputBuffer=(lhs,rhs)} = do
- clearLine
- putStrLn $ "input: <\x1b[32;1m" ++ lhs ++ rhs ++ "\x1b[m>"
- putStr (promptString q)
- hFlush stdout
- return q{inputBuffer=("","")}
-
-execCommand KillLastChar q@State{inputBuffer=([],_)} =
- cannotExecuteCommand q
-
-execCommand KillLastChar q@State{inputBuffer=(lhs,rhs)} = do
- moveCursorLeft 1
- clearLineFromCursorRight
- putStr rhs
- moveCursorLeft (length rhs)
- hFlush stdout
- return q{inputBuffer=(init lhs, rhs)}
-
-execCommand KillLastWord q@State{inputBuffer=([],_)} =
- cannotExecuteCommand q
-
-execCommand KillLastWord q@State{inputBuffer=(lhs,rhs)} = do
- let lhs' =
- dropWhileEnd (not . isSpace) $
- dropWhileEnd isSpace lhs
- killedCharCount = length lhs - length lhs'
- moveCursorLeft killedCharCount
- clearLineFromCursorRight
- putStr rhs
- moveCursorLeft (length rhs)
- hFlush stdout
- return q{inputBuffer=(lhs', rhs)}
-
-execCommand (AlertBadInput s) q@State{inputBuffer=(lhs,rhs)} = do
- clearLine
- putStrLn $ "unhandled input: <" ++ (concat $ map reform s) ++ ">"
- putStr $ (promptString q) ++ lhs ++ rhs
- moveCursorLeft (length rhs)
- hFlush stdout
- return q
- where
- reform c =
- if isPrint c
- then "\x1b[31m" ++ [c] ++ "\x1b[m"
- else
- "\x1b[1;31m" ++ (
- case ord c of
- 27 -> "^["
- _ -> "\\" ++ show (ord c)
- ) ++ "\x1b[m"
-
-
-clearLine =
- putStr "\x1b[2K" >>
- moveCursorLeft 80
-
-
-
-cannotExecuteCommand input = do
- ringBell
- hFlush stdout
- return input
-
-
-
-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"
diff --git a/defaultGetCommand.hs b/defaultGetCommand.hs
deleted file mode 100644
index b82f2ce..0000000
--- a/defaultGetCommand.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-
-
-
-
-defaultGetCommand :: IO Command
-defaultGetCommand = do
- c1 <- getChar
- case c1 of
- '\x1b' -> do
- c2 <- getChar
- case c2 of
- '[' -> do
- c3 <- getChar
- case c3 of
- 'C' -> return MoveCursorRight
- 'D' -> return MoveCursorLeft
- '3' -> do
- c4 <- getChar
- case c4 of
- '~' -> return KillNextChar
- _ -> return $ AlertBadInput (c1:c2:c3:c4:[])
- _ -> return $ AlertBadInput (c1:c2:c3:[])
- _ -> return $ AlertBadInput (c1:c2:[])
- _ ->
- if isPrint c1
- then return $ InsertChar c1
- else
- case ord c1 of
- 22 -> return InsertNextCharVerbatim
- 23 -> return KillLastWord
- 10 -> return ExecuteInputBuffer
- 127 -> return KillLastChar
- _ -> return $ AlertBadInput (c1:[])
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-25 11:40:15 +0000