From bc8d3ab9d134baa4517757f6f7ab80857361bd65 Mon Sep 17 00:00:00 2001 From: tv Date: Sun, 27 Jul 2014 11:02:45 +0200 Subject: initial commit --- Main-gut-ohne-transformers.hs | 340 +++++++++++++++++++++++++++++++++++ Main-kaputt-mit-mtl.hs | 396 +++++++++++++++++++++++++++++++++++++++++ Main.hs | 400 ++++++++++++++++++++++++++++++++++++++++++ Makefile | 47 +++++ OldMain.hs | 206 ++++++++++++++++++++++ default.nix | 24 +++ defaultGetCommand.hs | 33 ++++ hack.cabal | 20 +++ 8 files changed, 1466 insertions(+) create mode 100644 Main-gut-ohne-transformers.hs create mode 100644 Main-kaputt-mit-mtl.hs create mode 100644 Main.hs create mode 100644 Makefile create mode 100644 OldMain.hs create mode 100644 default.nix create mode 100644 defaultGetCommand.hs create mode 100644 hack.cabal diff --git a/Main-gut-ohne-transformers.hs b/Main-gut-ohne-transformers.hs new file mode 100644 index 0000000..c4646ec --- /dev/null +++ b/Main-gut-ohne-transformers.hs @@ -0,0 +1,340 @@ +{-# 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 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~" ""] + ++ [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.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~" ""] + ++ [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/Makefile b/Makefile new file mode 100644 index 0000000..bf7ea23 --- /dev/null +++ b/Makefile @@ -0,0 +1,47 @@ +pname := hack +nixpkgs := ${HOME}/src/nixpkgs + +configureFlags := -fdevelopment + +.PHONY: all build clean distclean configure run + +all: run + +clean: + cabal clean + +distclean: clean + rm -f result + rm -fR log + +ifeq (${NIX_MYENV_NAME},${pname}) + +build: + cabal build ${pname} + +configure: + cabal configure ${configureFlags} + +run: build + mkdir -p log + dist/build/${pname}/${pname} + +else +# +# setup development environment (and rerun make) +# + +ifdef nixpkgs +export NIX_PATH := nixpkgs=${nixpkgs} +endif + +# XXX result is a symlink we want to check +MAKEFLAGS += -L + +build configure run: result + echo make $@ | result/bin/load-env-${pname} + +result: default.nix + nix-build $< + +endif diff --git a/OldMain.hs b/OldMain.hs new file mode 100644 index 0000000..05fb955 --- /dev/null +++ b/OldMain.hs @@ -0,0 +1,206 @@ +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/default.nix b/default.nix new file mode 100644 index 0000000..bba6906 --- /dev/null +++ b/default.nix @@ -0,0 +1,24 @@ + +let + pkgs = import {}; + hsEnv = pkgs.haskellPackages.ghcWithPackages (hsPkgs : with hsPkgs; [ + mtl + ]); +in + +pkgs.myEnvFun { + name = "hack"; + buildInputs = with pkgs; [ + hsEnv + ]; + + # XXX https://nixos.org/wiki/Haskell says: + # Since tools (such as hdevtools [snap-loader-dynamic in our case]) that + # rely on the ghc-api to do haskell language manipulation are sensitive + # to nix-wrapping of ghc, we need the extraCmds line to ensure the + # proper ghc-wrapping environment variables are set inside the + # dev-environment shell. + extraCmds = '' + $(grep export ${hsEnv.outPath}/bin/ghc) + ''; +} diff --git a/defaultGetCommand.hs b/defaultGetCommand.hs new file mode 100644 index 0000000..b82f2ce --- /dev/null +++ b/defaultGetCommand.hs @@ -0,0 +1,33 @@ + + + + +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:[]) diff --git a/hack.cabal b/hack.cabal new file mode 100644 index 0000000..d398a93 --- /dev/null +++ b/hack.cabal @@ -0,0 +1,20 @@ +Name: hack +Version: 0.1 +Synopsis: Project Synopsis Here +Description: Project Description Here +License: AllRightsReserved +Author: Author +Maintainer: maintainer@example.com +Stability: Experimental +Category: Web +Build-type: Simple +Cabal-version: >=1.2 + +Executable hack + main-is: Main.hs + + Build-depends: + old-locale, + time, + mtl, + base -- cgit v1.2.3