summaryrefslogtreecommitdiffstats
path: root/Main-gut-ohne-transformers.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Main-gut-ohne-transformers.hs')
-rw-r--r--Main-gut-ohne-transformers.hs340
1 files changed, 0 insertions, 340 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)
-
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-20 22:24:37 +0000