From 3e9b581112b9ec12f0ec97f369f0d545ede4805b Mon Sep 17 00:00:00 2001 From: tv Date: Sun, 27 Jul 2014 11:03:34 +0200 Subject: rm cruft --- Main-gut-ohne-transformers.hs | 340 ------------------------------------ Main-kaputt-mit-mtl.hs | 396 ------------------------------------------ OldMain.hs | 206 ---------------------- defaultGetCommand.hs | 33 ---- 4 files changed, 975 deletions(-) delete mode 100644 Main-gut-ohne-transformers.hs delete mode 100644 Main-kaputt-mit-mtl.hs delete mode 100644 OldMain.hs delete mode 100644 defaultGetCommand.hs 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~" ""] - ++ [unboundSequence "\x1b[5~" ""] -- page up - ++ [unboundSequence "\x1b[6~" ""] -- page dn - ++ [unboundSequence "\x1b[7~" ""] - ++ [unboundSequence "\x1b[8~" ""] - ++ [unboundSequence "\x1b[2$" ""] - ++ [unboundSequence "\x1b[5$" ""] -- page up - ++ [unboundSequence "\x1b[6$" ""] -- page dn - ++ [unboundSequence "\x1b[7$" ""] - ++ [unboundSequence "\x1b[8$" ""] - ++ [unboundSequence "\x1b\x1b[2$" ""] - ++ [unboundSequence "\x1b\x1b[5$" ""] -- page up - ++ [unboundSequence "\x1b\x1b[6$" ""] -- page dn - ++ [unboundSequence "\x1b\x1b[7$" ""] - ++ [unboundSequence "\x1b\x1b[8$" ""] - ++ [unboundSequence "\x1b\x1b[A" ""] - ++ [unboundSequence "\x1b\x1b[B" ""] - ++ [unboundSequence "\x1b\x1b[C" ""] - ++ [unboundSequence "\x1b\x1b[D" ""] - ++ [unboundSequence "\x1b\x1b[a" ""] - ++ [unboundSequence "\x1b\x1b[b" ""] - ++ [unboundSequence "\x1b\x1b[c" ""] - ++ [unboundSequence "\x1b\x1b[d" ""] - ++ [unboundSequence "\x1b[a" ""] - ++ [unboundSequence "\x1b[b" ""] - ++ [unboundSequence "\x1b[c" ""] - ++ [unboundSequence "\x1b[d" ""] - ++ [unboundSequence "\x1bOa" ""] - ++ [unboundSequence "\x1bOb" ""] - ++ [unboundSequence "\x1bOc" ""] - ++ [unboundSequence "\x1bOd" ""] - ++ [unboundSequence "\x1b\x1bOa" ""] - ++ [unboundSequence "\x1b\x1bOb" ""] - ++ [unboundSequence "\x1b\x1bOc" ""] - ++ [unboundSequence "\x1b\x1bOd" ""] - ++ [unboundSequence "\x1b[11~" ""] - ++ [unboundSequence "\x1b[12~" ""] - ++ [unboundSequence "\x1b[13~" ""] - ++ [unboundSequence "\x1b[14~" ""] - ++ [unboundSequence "\x1b[15~" ""] - ++ [unboundSequence "\x1b[17~" ""] - ++ [unboundSequence "\x1b[18~" ""] - ++ [unboundSequence "\x1b[19~" ""] - ++ [unboundSequence "\x1b[20~" ""] - ++ [unboundSequence "\x1b[21~" ""] - ++ [unboundSequence "\x1b[23~" ""] - ++ [unboundSequence "\x1b[24~" ""] - - ++ [unboundSequence "\x1b\x1b[2~" ""] - ++ [unboundSequence "\x1b\x1b[3~" ""] - ++ map (\ i -> unboundSequence ("\x1b\x1b[" ++ show i ++ "~") - ("")) - [11..24] - ++ [unboundSequence "\x1b\x7f" ""] - ++ [unboundSequence "\x1b\x0a" ""] - - -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~" ""] - ++ [unboundSequence "\x1b[5~" ""] -- page up - ++ [unboundSequence "\x1b[6~" ""] -- page dn - ++ [unboundSequence "\x1b[7~" ""] - ++ [unboundSequence "\x1b[8~" ""] - ++ [unboundSequence "\x1b[2$" ""] - ++ [unboundSequence "\x1b[5$" ""] -- page up - ++ [unboundSequence "\x1b[6$" ""] -- page dn - ++ [unboundSequence "\x1b[7$" ""] - ++ [unboundSequence "\x1b[8$" ""] - ++ [unboundSequence "\x1b\x1b[2$" ""] - ++ [unboundSequence "\x1b\x1b[5$" ""] -- page up - ++ [unboundSequence "\x1b\x1b[6$" ""] -- page dn - ++ [unboundSequence "\x1b\x1b[7$" ""] - ++ [unboundSequence "\x1b\x1b[8$" ""] - ++ [unboundSequence "\x1b\x1b[A" ""] - ++ [unboundSequence "\x1b\x1b[B" ""] - ++ [unboundSequence "\x1b\x1b[C" ""] - ++ [unboundSequence "\x1b\x1b[D" ""] - ++ [unboundSequence "\x1b\x1b[a" ""] - ++ [unboundSequence "\x1b\x1b[b" ""] - ++ [unboundSequence "\x1b\x1b[c" ""] - ++ [unboundSequence "\x1b\x1b[d" ""] - ++ [unboundSequence "\x1b[a" ""] - ++ [unboundSequence "\x1b[b" ""] - ++ [unboundSequence "\x1b[c" ""] - ++ [unboundSequence "\x1b[d" ""] - ++ [unboundSequence "\x1bOa" ""] - ++ [unboundSequence "\x1bOb" ""] - ++ [unboundSequence "\x1bOc" ""] - ++ [unboundSequence "\x1bOd" ""] - ++ [unboundSequence "\x1b\x1bOa" ""] - ++ [unboundSequence "\x1b\x1bOb" ""] - ++ [unboundSequence "\x1b\x1bOc" ""] - ++ [unboundSequence "\x1b\x1bOd" ""] - ++ [unboundSequence "\x1b[11~" ""] - ++ [unboundSequence "\x1b[12~" ""] - ++ [unboundSequence "\x1b[13~" ""] - ++ [unboundSequence "\x1b[14~" ""] - ++ [unboundSequence "\x1b[15~" ""] - ++ [unboundSequence "\x1b[17~" ""] - ++ [unboundSequence "\x1b[18~" ""] - ++ [unboundSequence "\x1b[19~" ""] - ++ [unboundSequence "\x1b[20~" ""] - ++ [unboundSequence "\x1b[21~" ""] - ++ [unboundSequence "\x1b[23~" ""] - ++ [unboundSequence "\x1b[24~" ""] - - ++ [unboundSequence "\x1b\x1b[2~" ""] - ++ [unboundSequence "\x1b\x1b[3~" ""] - ++ map (\ i -> unboundSequence ("\x1b\x1b[" ++ show i ++ "~") - ("")) - [11..24] - ++ [unboundSequence "\x1b\x7f" ""] - ++ [unboundSequence "\x1b\x0a" ""] - - -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:[]) -- cgit v1.2.3