From 894a1ac90fcf36ee63096f7bfce48aee7047cd2c Mon Sep 17 00:00:00 2001 From: tv Date: Mon, 9 Mar 2026 14:56:38 +0100 Subject: Main: src/ -> app/ --- app/Main.hs | 633 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ app/Process.hs | 108 ++++++++++ hack.cabal | 4 +- src/Main.hs | 633 --------------------------------------------------------- src/Process.hs | 108 ---------- 5 files changed, 744 insertions(+), 742 deletions(-) create mode 100644 app/Main.hs create mode 100644 app/Process.hs delete mode 100644 src/Main.hs delete mode 100644 src/Process.hs diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..3c62184 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,633 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Lens hiding (Empty, imap) +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Data.Char +import Data.IORef +import Data.List hiding (delete) +import Numeric (showIntAtBase) +import System.IO +--import System.Posix.Signals + +import GHC.Stats (getRTSStats) + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer + +import Data.Map (Map) +import qualified Data.Map as Map + +import Hack.Buffer +import Process +import Scanner +import Blessings +import qualified Blessings.Internal as Blessings +import Blessings.String () + + +data Mode + = InsertMode + | NormalMode + | VerbatimMode + | SelectRegisterMode + | DeleteMode + | YankMode + deriving (Eq) + +instance Show Mode where + show NormalMode = "normal" + show InsertMode = "insert" + show VerbatimMode = "verbatim" + show SelectRegisterMode = "select register" + show DeleteMode = "delete" + show YankMode = "yank" + + +data VTConfig = VTConfig + { withOutput :: IO () -> IO () + } + +data VTState = VTState + { _buffer :: Buffer + , _mode :: Mode + , _processCount :: Int + , _count :: Maybe Int + , _register :: Char + , _registers :: Map Char String + } + +instance Show VTState where + show VTState{..} = + "" + +makeLenses ''VTState + + +defaultRegister :: Char +defaultRegister = '"' + +main :: IO () +main = do + hSetEcho stdin False + hSetBuffering stdin NoBuffering + + -- WINCH + -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing + + let st = VTState + { _mode = InsertMode + , _buffer = ("!while date; do sleep 1; done", "") + , _processCount = 0 + , _count = Nothing + , _register = defaultRegister + , _registers = Map.empty + } + + lockRef <- newMVar () + qRef <- newIORef st + let _putState = writeIORef qRef -- TODO atomicModifyIORef (?) + _getState = readIORef qRef + _withOutput a = do + q <- _getState + withMVar lockRef $ \ _ -> do + clearLine + a + renderInputLine (_count q) (_mode q) (_buffer q) + hFlush stdout + + let cf = VTConfig + { withOutput = _withOutput + } + + -- render initial input line + _withOutput $ return () + + uiThread cf _putState _getState + + +uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO () +uiThread cf putState getState = forever $ do + q0 <- getState + + + _ <- hLookAhead stdin -- wait for input + --t0 <- getCurrentTime + s <- scan stdin + --t1 <- getCurrentTime + --putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++ + -- (show $ diffUTCTime t1 t0) + -- ++ ": \"\ESC[35m" ++ (s >>= colorize . toChar) + -- ++ "\ESC[m\"" + --case res of + -- Left msg -> putStrLn $ " error: " ++ msg + -- Right _ -> return () + + -- TODO don't leak C + let ScanKey k = s + let cmd = getCommand (_mode q0) k + + --withOutput cf $ do + -- putStrLn $ show cmd + + ((eitCmd, lns), q1) <- runVT cf q0 (execCommand cmd) + + -- TODO only putState if it has changed (?) + putState q1 + + withOutput cf $ do + forM_ lns putStrLn + + whenLeft eitCmd $ \err -> + ringBell >> putStrLn (prettyError err) + + --when (mode st /= mode st') $ do + -- putStrLn $ "change mode: " ++ (show $ mode st') + + + +data Command + = AlertBadInput String + | DebugShowVTState + | InsertString String + | ExecuteInputBuffer + | MoveCursor Motion + | MoveCursorLeftIfAtEndOfLine + | MoveCursorWarn Motion + | ChangeMode Mode + -- TODO Move Count Motion + -- Delete Count Register Motion + -- etc. + | Combine Command Command + | Nop + | RingBell + | AppendCount Int + | SetCount (Maybe Int) + | SetRegister Char + | Delete Motion + | DeleteEntireLine + | Yank Motion + + +instance Semigroup Command where + (<>) = Combine + + +instance Monoid Command where + mempty = Nop + + + +data ExecError + = UnhandledInputError String + | OtherError String + + +prettyError :: ExecError -> String + +prettyError (UnhandledInputError s) = + pp $ SGR [31] $ + "unhandled input: <" <> SGR [1] (gaudySpecial [35,1] s) <> ">" + +prettyError (OtherError s) = + pp $ SGR [31] $ gaudySpecial [35] s + + + +newtype VT a = VT + (ReaderT VTConfig + (ExceptT ExecError + (WriterT [String] + (StateT VTState IO + ))) + a) + deriving + ( Applicative + , Functor + , Monad + , MonadError ExecError + , MonadIO + , MonadReader VTConfig + , MonadState VTState + , MonadWriter [String] + ) + +runVT :: + VTConfig -> VTState -> VT a -> IO ((Either ExecError a, [String]), VTState) + +runVT cf st (VT a) = + runStateT (runWriterT (runExceptT (runReaderT a cf))) st + + + +insertString :: String -> Buffer -> Buffer +insertString s (ls, rs) = (ls ++ s, rs) + + +execCommand :: Command -> VT () + +execCommand DebugShowVTState = + get >>= tell . (:[]) . pp . SGR [35] . Plain . show + +execCommand (MoveCursor x) = do + c <- uses count (maybe 1 id) + buffer %= move x c + + -- TODO apply mode constraints somewhere else + whenM (uses mode (==NormalMode) >>&& uses (buffer . _2) null) $ + buffer %= gotoLeft 1 + +-- TODO merge with mode constraints in MoveCursor +execCommand MoveCursorLeftIfAtEndOfLine = do + whenM (uses (buffer . _2) null) $ + buffer %= gotoLeft 1 + +-- TODO Make this "real" warnings, i.e. don't throwError but tell. This +-- is required in order to perform any Combine-d commands regardless of +-- failed moves. Currently this is only used to SetCount Nothing (which +-- is defunct atm) Alternatively we could simply reset the state when an +-- error happens Discus! +execCommand (MoveCursorWarn x) = do + b0 <- use buffer + execCommand (MoveCursor x) + b1 <- use buffer + + -- TODO make this a warning or else ... + when (b0 == b1) $ + throwError (OtherError $ "your motion has no effect: " ++ show x) + +execCommand (ChangeMode m) = + mode .= m + +execCommand (InsertString s) = + buffer %= insertString s + +execCommand ExecuteInputBuffer = do + + ---- XXX hack to replace empty command line + --gets (null . showBuffer . buffer) >>= flip when + -- (modify $ \q -> q { buffer = ("!","") }) + + st <- get + + case showBuffer (_buffer st) of + ":c" -> do + let f i = pp $ SGR [38,5,i] $ Plain $ padl 3 '0' $ show i + tell [ intercalate " " $ map f [0..255] + ] + ":r" -> do + tell [ "--- Registers ---" ] + tell $ map (\(r, s) -> ['"', r] ++ " " ++ s) -- TODO pp + $ Map.toList (_registers st) + ":s" -> do + s <- liftIO getRTSStats + tell [ show s ] + '!' : cmdline -> do + --tell [ "spawn: " ++ cmdline ] + -- "input: <" ++ (showBuffer b >>= reform 32) ++ ">" ] + -- TODO register process + i <- processCount <<+= 1 + cf <- ask + liftIO $ forkIO $ spawn i (withOutput cf) cmdline + return () + "" -> do + liftIO ringBell + s -> do + let s' = SGR [32] $ gaudySpecial [1] s + tell [ pp $ "input: " <> s' + , pp $ SGR [35] $ gaudySpecial [1] $ pp s' + ] + + buffer .= emptyBuffer + +execCommand (AlertBadInput s) = + throwError (UnhandledInputError s) + +execCommand (Combine c1 c2) = do + cf <- ask + q0 <- get + + ((eSt1, lines1), q1) <- liftIO $ runVT cf q0 (execCommand c1) + + -- TODO "stack trace" + whenLeft eSt1 throwError + + ((eSt2, lines2), q2) <- liftIO $ runVT cf q1 (execCommand c2) + + -- TODO "stack trace" + whenLeft eSt2 throwError + + tell lines1 + tell lines2 + + put q2 + +execCommand Nop = return () + +execCommand RingBell = liftIO ringBell + +execCommand (AppendCount i) = + count %= Just . (i+) . maybe 0 (10*) + +execCommand (SetCount i) = + count .= i + +execCommand (SetRegister c) = + register .= c + +execCommand DeleteEntireLine = + -- TODO Numbered registers "0 to "9 + -- Small delete _register "- + modify $ \q -> do + + let v = Just $ showBuffer $ _buffer q + r = _register q + + q & buffer .~ emptyBuffer + & register .~ defaultRegister + & registers %~ (at r .~ v) . + (at defaultRegister .~ v) + +-- TODO yank into "- (smallDeleteRegister) when deleting less than one line +-- TODO reset register after this command (q & register .~ defaultRegister) +execCommand (Delete x) = do + b0 <- use buffer + c <- uses count (maybe 1 id) + buffer %= delete x c + b1 <- use buffer + + when (b0 == b1) $ throwError (OtherError "nothing to delete") + + +-- TODO Yank register motion (after motion has incorporated count) +execCommand (Yank x) = + modify $ \q@VTState{..} -> do + let c = maybe 1 id _count + y = select x c _buffer + + q & registers %~ (at _register .~ Just y) + + +-- XXX assumes that the cursor is already at the (cleared) input line +-- TODO renderInputLine looks like it wants to be -> VT () +renderInputLine :: Maybe Int -> Mode -> Buffer -> IO () +renderInputLine mb_cnt m (lhs, rhs) = do + renderRight $ + SGR [30,1] $ + Plain (show m) <> + maybe Empty + (("["<>) . (<>"]") . SGR [33,1] . Plain . show) + mb_cnt + renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs) + moveCursorLeft $ length $ lit rhs + + +renderLeft :: Blessings String -> IO () +renderLeft = putStr . pp + + +renderRight :: Blessings String -> IO () +renderRight a = do + saveCursor + moveCursorRight 1024 -- XXX obviously, this is a hack..^_^ + moveCursorLeft $ Blessings.length a - 1 + renderLeft a + unsaveCursor + + + +promptString :: Mode -> Blessings String +promptString NormalMode = SGR [33,1] "@ " +promptString InsertMode = "> " +promptString SelectRegisterMode = "\" " +promptString DeleteMode = SGR [31,1] "> " +promptString VerbatimMode = SGR [34,1] "^ " +promptString YankMode = SGR [31,1] "y " + + +spans :: (a -> Bool) -> [a] -> [Either [a] [a]] +spans p xs = f_r (span p_r xs) + where + p_r = not . p + p_l = p + f_r (as, bs) = Right as : if null bs then [] else f_l (span p_l bs) + f_l (as, bs) = Left as : if null bs then [] else f_r (span p_r bs) + + +gaudySpans :: Pm -> (Char -> Bool) -> String -> Blessings String +gaudySpans c p = + mconcat . map (either (SGR c . Plain . lit) Plain) . spans p + + +gaudySpecial :: Pm -> String -> Blessings String +gaudySpecial c = gaudySpans c (not . isPrint) + + +lit :: String -> String +lit = (>>= f) + where f '\ESC' = "^[" + f c = showLitChar c "" + + +clearLine :: IO () +clearLine = + putStr "\ESC[2K" >> + moveCursorLeft 1024 + + +ringBell :: IO () +ringBell = putStr "\x07" -- BEL '\a' + + +saveCursor :: IO () +saveCursor = putStr "\ESC[s" + +unsaveCursor :: IO () +unsaveCursor = putStr "\ESC[u" + + +moveCursorLeft :: Int -> IO () +moveCursorLeft 0 = return () +moveCursorLeft i = putStr $ "\ESC[" ++ show i ++ "D" + + +moveCursorRight :: Int -> IO () +moveCursorRight 0 = return () +moveCursorRight i = putStr $ "\ESC[" ++ show i ++ "C" + + +-- TODO? charToCode c = "\\x" ++ showHex (ord c) +charToCode :: Char -> String +charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) "" + + +dmap :: Keymap +dmap = + [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing) + , ("\ESC[24~", DebugShowVTState) + , ("d", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing) + , ("$", Yank ToEndOfLine <> + Delete ToEndOfLine <> + ChangeMode NormalMode <> + SetCount Nothing <> + MoveCursorLeftIfAtEndOfLine + ) + , ("0", Yank ToStartOfLine <> + Delete ToStartOfLine <> + ChangeMode NormalMode <> SetCount Nothing) + , ("h", Yank CharsBackward <> + Delete CharsBackward <> + ChangeMode NormalMode <> SetCount Nothing) + , ("l", Yank CharsForward <> + Delete CharsForward <> + ChangeMode NormalMode <> + SetCount Nothing <> + MoveCursorLeftIfAtEndOfLine + ) + ] + + +selectRegisterMap :: Keymap +selectRegisterMap = + [ ("\ESC", ChangeMode NormalMode) + ] + ++ (map (\c -> ([c], SetRegister c <> ChangeMode NormalMode)) + (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".%#:-\"")) + + +-- TODO maybe in normal mode reset count (SetCount Nothing) after each +-- command doesn't alter the count. How would this work together with +-- ChangeMode DeleteMode +-- TODO 2017-08-06 +-- initialize count whenever nmap is entered +-- ditch SetCount Nothing +-- pass count to commands / modes +nmap :: Keymap +nmap = + [ ("\ESC", SetCount Nothing) + -- ^TODO RingBell if count is already Nothing + -- TODO cancel any unfinished commands + , ("i", ChangeMode InsertMode <> SetCount Nothing) + , ("a", ChangeMode InsertMode <> SetCount Nothing <> MoveCursor CharsForward) + , ("I", ChangeMode InsertMode <> MoveCursor ToStartOfLine) + , ("A", ChangeMode InsertMode <> MoveCursor ToEndOfLine) + , ("|", MoveCursorWarn ToColumn <> SetCount Nothing) + , ("$", MoveCursorWarn ToEndOfLine <> SetCount Nothing) + , ("h", MoveCursorWarn CharsBackward <> SetCount Nothing) + , ("l", MoveCursorWarn CharsForward <> SetCount Nothing) + , ("b", MoveCursorWarn WordsBackward <> SetCount Nothing) + , ("w", MoveCursorWarn WordsForward <> SetCount Nothing) + , ("d", ChangeMode DeleteMode) + , ("y", ChangeMode YankMode) + , ("\"", ChangeMode SelectRegisterMode <> SetCount Nothing) + , ("\ESC[24~", DebugShowVTState) + , ("\ESC[C", MoveCursorWarn CharsForward <> SetCount Nothing) + , ("\ESC[D", MoveCursorWarn CharsBackward <> SetCount Nothing) + , ("\n", ExecuteInputBuffer <> ChangeMode InsertMode <> SetCount Nothing) + ] + ++ (map (\i -> (show i, AppendCount i)) [0..9]) + -- XXX + -- if we would want 0 to move the cursor to the first character of the + -- line, then we would need ("0", x) + -- where + -- x :: Command + -- x = Embed f + -- f :: VT Command + -- f = gets (isJust . count) >>= + -- return . bool (MoveCursor ToStartOfLine) (AppendCount 0) + -- bool :: a -> a -> Bool -> a + -- bool _ a True = a + -- bool a _ False = a + -- and also we would have to extend data Command by Embed (VT Command) + -- execCommand (Embed a) = a >>= execCommand + -- + -- This all looks quite strange, so just use | if you want that movement... + -- ^_^ + + +imap :: Keymap +imap = + [ ("\ESC", ChangeMode NormalMode <> MoveCursor CharsBackward) + , ("\x01", MoveCursorWarn ToStartOfLine) + , ("\x05", MoveCursorWarn ToEndOfLine) + , ("\ESC[24~", DebugShowVTState) + , ("\ESC[3~", Delete CharsForward) + , ("\ESC[C", MoveCursorWarn CharsForward) + , ("\ESC[D", MoveCursorWarn CharsBackward) + , ("\x16", ChangeMode VerbatimMode) -- ^V + , ("\x17", Delete WordsBackward) -- ^W + , ("\x0a", ExecuteInputBuffer) + , ("\x7f", Delete CharsBackward) -- Delete + , ("\x08", Delete CharsBackward) -- BackSpace + , ("\ESCOc", MoveCursorWarn WordsForward) + , ("\ESCOd", MoveCursorWarn WordsBackward) + ] + +ymap :: Keymap +ymap = + [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing) + , ("\ESC[24~", DebugShowVTState) + -- TODO , ("y", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing) + , ("$", Yank ToEndOfLine <> ChangeMode NormalMode <> SetCount Nothing) + , ("0", Yank ToStartOfLine <> ChangeMode NormalMode <> SetCount Nothing) + , ("h", Yank CharsBackward <> ChangeMode NormalMode <> SetCount Nothing) + , ("l", Yank CharsForward <> ChangeMode NormalMode <> SetCount Nothing) + ] + + +type Keymap = [(String, Command)] + + +getCommand :: Mode -> String -> Command + +getCommand InsertMode s = maybe (InsertString s) id $ lookup s imap + +getCommand NormalMode s = + maybe (AlertBadInput s <> SetCount Nothing) id $ lookup s nmap + +getCommand VerbatimMode s = InsertString s <> ChangeMode InsertMode + +getCommand SelectRegisterMode s = + maybe (AlertBadInput s) id $ lookup s selectRegisterMap + -- ^ TODO clear bad input + +getCommand DeleteMode s = maybe (AlertBadInput s) id $ lookup s dmap + +getCommand YankMode s = maybe (AlertBadInput s) id $ lookup s ymap + + +-- TODO Control.Monad.whenLeft +whenLeft :: Monad m => Either a b -> (a -> m ()) -> m () +whenLeft (Left x) f = f x +whenLeft _ _ = return () + +whenM :: Monad m => m Bool -> m () -> m () +whenM a b = a >>= flip when b + +infixl 1 >>&& + +(>>&&) :: Monad m => m Bool -> m Bool -> m Bool +a >>&& b = do + ra <- a + rb <- b + return $ ra && rb + + +padl :: Int -> a -> [a] -> [a] +padl n c s + | length s < n = padl n c (c : s) + | otherwise = s diff --git a/app/Process.hs b/app/Process.hs new file mode 100644 index 0000000..41ea113 --- /dev/null +++ b/app/Process.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Process + ( spawn + , module System.Process + ) where + +import Control.Concurrent +import Control.Monad (unless, when) +import Data.Monoid +import System.Exit +import System.IO +import System.Process + +import Blessings +import Blessings.String () + + +type OutputWrapper = IO () -> IO () + +data OutStreamType = Stderr | Stdout + +color :: OutStreamType -> Ps +color Stderr = 31 +color Stdout = 32 + +data ReaperConfig = ReaperConfig + { withOutput :: OutputWrapper + , jobName :: String + , openFdsRef :: MVar Int + , processHandle :: ProcessHandle + , streamHandle :: Handle + , streamType :: OutStreamType + } + + +spawn :: Int -> OutputWrapper -> String -> IO () +spawn jobId _withOutput cmdline = do + + -- TODO stdin + (Nothing, Just hOut, Just hErr, ph) <- + createProcess (shell cmdline) + { std_in = Inherit -- TODO close + , std_out = CreatePipe + , std_err = CreatePipe + } + + _openFdsRef <- newMVar 2 + + let rcOut = ReaperConfig + { streamType = Stdout + , streamHandle = hOut + , withOutput = _withOutput + , jobName = '&' : show jobId + , openFdsRef = _openFdsRef + , processHandle = ph + } + rcErr = rcOut + { streamType = Stderr + , streamHandle = hErr + } + + forkIO $ reap rcOut + reap rcErr + + +reap :: ReaperConfig -> IO () +reap rc@ReaperConfig{..} = do + forLines_ streamHandle $ \line -> + withOutput $ putStrLn $ pp $ + SGR [35] (Plain jobName) <> + Plain " " <> + SGR [color streamType] (Plain line) + + i <- decMVar openFdsRef + + --withOutput $ + -- putStrLn $ "\x1b[35m" ++ name ++ "\x1b[m eof" + + when (i == 0) $ finish rc + + hClose streamHandle + myThreadId >>= killThread + + +finish :: ReaperConfig -> IO () +finish ReaperConfig{..} = do + exitCode <- waitForProcess processHandle + when (exitCode /= ExitSuccess) $ + withOutput $ putStrLn $ pp $ + SGR [35] (Plain jobName) <> + Plain " " <> + SGR [31] (Plain $ show exitCode) + + +decMVar :: MVar Int -> IO Int +decMVar = + flip modifyMVar dec + where + dec i = let i' = i - 1 in return (i', i') + + + +-- TODO move utilities somewhere else +forLines_ :: Handle -> (String -> IO ()) -> IO () +forLines_ h f = rec + where + rec = hIsEOF h >>= flip unless (hGetLine h >>= f >> rec) diff --git a/hack.cabal b/hack.cabal index a03c107..f7c8d3a 100644 --- a/hack.cabal +++ b/hack.cabal @@ -15,13 +15,15 @@ library hs-source-dirs: src Executable hack - hs-source-dirs: src main-is: Main.hs + hs-source-dirs: app + other-modules: Process Build-depends: blessings, containers, data-default, + hack, lens, mtl, old-locale, diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index 3c62184..0000000 --- a/src/Main.hs +++ /dev/null @@ -1,633 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Control.Lens hiding (Empty, imap) -import Control.Applicative -import Control.Concurrent -import Control.Monad -import Data.Char -import Data.IORef -import Data.List hiding (delete) -import Numeric (showIntAtBase) -import System.IO ---import System.Posix.Signals - -import GHC.Stats (getRTSStats) - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer - -import Data.Map (Map) -import qualified Data.Map as Map - -import Hack.Buffer -import Process -import Scanner -import Blessings -import qualified Blessings.Internal as Blessings -import Blessings.String () - - -data Mode - = InsertMode - | NormalMode - | VerbatimMode - | SelectRegisterMode - | DeleteMode - | YankMode - deriving (Eq) - -instance Show Mode where - show NormalMode = "normal" - show InsertMode = "insert" - show VerbatimMode = "verbatim" - show SelectRegisterMode = "select register" - show DeleteMode = "delete" - show YankMode = "yank" - - -data VTConfig = VTConfig - { withOutput :: IO () -> IO () - } - -data VTState = VTState - { _buffer :: Buffer - , _mode :: Mode - , _processCount :: Int - , _count :: Maybe Int - , _register :: Char - , _registers :: Map Char String - } - -instance Show VTState where - show VTState{..} = - "" - -makeLenses ''VTState - - -defaultRegister :: Char -defaultRegister = '"' - -main :: IO () -main = do - hSetEcho stdin False - hSetBuffering stdin NoBuffering - - -- WINCH - -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing - - let st = VTState - { _mode = InsertMode - , _buffer = ("!while date; do sleep 1; done", "") - , _processCount = 0 - , _count = Nothing - , _register = defaultRegister - , _registers = Map.empty - } - - lockRef <- newMVar () - qRef <- newIORef st - let _putState = writeIORef qRef -- TODO atomicModifyIORef (?) - _getState = readIORef qRef - _withOutput a = do - q <- _getState - withMVar lockRef $ \ _ -> do - clearLine - a - renderInputLine (_count q) (_mode q) (_buffer q) - hFlush stdout - - let cf = VTConfig - { withOutput = _withOutput - } - - -- render initial input line - _withOutput $ return () - - uiThread cf _putState _getState - - -uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO () -uiThread cf putState getState = forever $ do - q0 <- getState - - - _ <- hLookAhead stdin -- wait for input - --t0 <- getCurrentTime - s <- scan stdin - --t1 <- getCurrentTime - --putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++ - -- (show $ diffUTCTime t1 t0) - -- ++ ": \"\ESC[35m" ++ (s >>= colorize . toChar) - -- ++ "\ESC[m\"" - --case res of - -- Left msg -> putStrLn $ " error: " ++ msg - -- Right _ -> return () - - -- TODO don't leak C - let ScanKey k = s - let cmd = getCommand (_mode q0) k - - --withOutput cf $ do - -- putStrLn $ show cmd - - ((eitCmd, lns), q1) <- runVT cf q0 (execCommand cmd) - - -- TODO only putState if it has changed (?) - putState q1 - - withOutput cf $ do - forM_ lns putStrLn - - whenLeft eitCmd $ \err -> - ringBell >> putStrLn (prettyError err) - - --when (mode st /= mode st') $ do - -- putStrLn $ "change mode: " ++ (show $ mode st') - - - -data Command - = AlertBadInput String - | DebugShowVTState - | InsertString String - | ExecuteInputBuffer - | MoveCursor Motion - | MoveCursorLeftIfAtEndOfLine - | MoveCursorWarn Motion - | ChangeMode Mode - -- TODO Move Count Motion - -- Delete Count Register Motion - -- etc. - | Combine Command Command - | Nop - | RingBell - | AppendCount Int - | SetCount (Maybe Int) - | SetRegister Char - | Delete Motion - | DeleteEntireLine - | Yank Motion - - -instance Semigroup Command where - (<>) = Combine - - -instance Monoid Command where - mempty = Nop - - - -data ExecError - = UnhandledInputError String - | OtherError String - - -prettyError :: ExecError -> String - -prettyError (UnhandledInputError s) = - pp $ SGR [31] $ - "unhandled input: <" <> SGR [1] (gaudySpecial [35,1] s) <> ">" - -prettyError (OtherError s) = - pp $ SGR [31] $ gaudySpecial [35] s - - - -newtype VT a = VT - (ReaderT VTConfig - (ExceptT ExecError - (WriterT [String] - (StateT VTState IO - ))) - a) - deriving - ( Applicative - , Functor - , Monad - , MonadError ExecError - , MonadIO - , MonadReader VTConfig - , MonadState VTState - , MonadWriter [String] - ) - -runVT :: - VTConfig -> VTState -> VT a -> IO ((Either ExecError a, [String]), VTState) - -runVT cf st (VT a) = - runStateT (runWriterT (runExceptT (runReaderT a cf))) st - - - -insertString :: String -> Buffer -> Buffer -insertString s (ls, rs) = (ls ++ s, rs) - - -execCommand :: Command -> VT () - -execCommand DebugShowVTState = - get >>= tell . (:[]) . pp . SGR [35] . Plain . show - -execCommand (MoveCursor x) = do - c <- uses count (maybe 1 id) - buffer %= move x c - - -- TODO apply mode constraints somewhere else - whenM (uses mode (==NormalMode) >>&& uses (buffer . _2) null) $ - buffer %= gotoLeft 1 - --- TODO merge with mode constraints in MoveCursor -execCommand MoveCursorLeftIfAtEndOfLine = do - whenM (uses (buffer . _2) null) $ - buffer %= gotoLeft 1 - --- TODO Make this "real" warnings, i.e. don't throwError but tell. This --- is required in order to perform any Combine-d commands regardless of --- failed moves. Currently this is only used to SetCount Nothing (which --- is defunct atm) Alternatively we could simply reset the state when an --- error happens Discus! -execCommand (MoveCursorWarn x) = do - b0 <- use buffer - execCommand (MoveCursor x) - b1 <- use buffer - - -- TODO make this a warning or else ... - when (b0 == b1) $ - throwError (OtherError $ "your motion has no effect: " ++ show x) - -execCommand (ChangeMode m) = - mode .= m - -execCommand (InsertString s) = - buffer %= insertString s - -execCommand ExecuteInputBuffer = do - - ---- XXX hack to replace empty command line - --gets (null . showBuffer . buffer) >>= flip when - -- (modify $ \q -> q { buffer = ("!","") }) - - st <- get - - case showBuffer (_buffer st) of - ":c" -> do - let f i = pp $ SGR [38,5,i] $ Plain $ padl 3 '0' $ show i - tell [ intercalate " " $ map f [0..255] - ] - ":r" -> do - tell [ "--- Registers ---" ] - tell $ map (\(r, s) -> ['"', r] ++ " " ++ s) -- TODO pp - $ Map.toList (_registers st) - ":s" -> do - s <- liftIO getRTSStats - tell [ show s ] - '!' : cmdline -> do - --tell [ "spawn: " ++ cmdline ] - -- "input: <" ++ (showBuffer b >>= reform 32) ++ ">" ] - -- TODO register process - i <- processCount <<+= 1 - cf <- ask - liftIO $ forkIO $ spawn i (withOutput cf) cmdline - return () - "" -> do - liftIO ringBell - s -> do - let s' = SGR [32] $ gaudySpecial [1] s - tell [ pp $ "input: " <> s' - , pp $ SGR [35] $ gaudySpecial [1] $ pp s' - ] - - buffer .= emptyBuffer - -execCommand (AlertBadInput s) = - throwError (UnhandledInputError s) - -execCommand (Combine c1 c2) = do - cf <- ask - q0 <- get - - ((eSt1, lines1), q1) <- liftIO $ runVT cf q0 (execCommand c1) - - -- TODO "stack trace" - whenLeft eSt1 throwError - - ((eSt2, lines2), q2) <- liftIO $ runVT cf q1 (execCommand c2) - - -- TODO "stack trace" - whenLeft eSt2 throwError - - tell lines1 - tell lines2 - - put q2 - -execCommand Nop = return () - -execCommand RingBell = liftIO ringBell - -execCommand (AppendCount i) = - count %= Just . (i+) . maybe 0 (10*) - -execCommand (SetCount i) = - count .= i - -execCommand (SetRegister c) = - register .= c - -execCommand DeleteEntireLine = - -- TODO Numbered registers "0 to "9 - -- Small delete _register "- - modify $ \q -> do - - let v = Just $ showBuffer $ _buffer q - r = _register q - - q & buffer .~ emptyBuffer - & register .~ defaultRegister - & registers %~ (at r .~ v) . - (at defaultRegister .~ v) - --- TODO yank into "- (smallDeleteRegister) when deleting less than one line --- TODO reset register after this command (q & register .~ defaultRegister) -execCommand (Delete x) = do - b0 <- use buffer - c <- uses count (maybe 1 id) - buffer %= delete x c - b1 <- use buffer - - when (b0 == b1) $ throwError (OtherError "nothing to delete") - - --- TODO Yank register motion (after motion has incorporated count) -execCommand (Yank x) = - modify $ \q@VTState{..} -> do - let c = maybe 1 id _count - y = select x c _buffer - - q & registers %~ (at _register .~ Just y) - - --- XXX assumes that the cursor is already at the (cleared) input line --- TODO renderInputLine looks like it wants to be -> VT () -renderInputLine :: Maybe Int -> Mode -> Buffer -> IO () -renderInputLine mb_cnt m (lhs, rhs) = do - renderRight $ - SGR [30,1] $ - Plain (show m) <> - maybe Empty - (("["<>) . (<>"]") . SGR [33,1] . Plain . show) - mb_cnt - renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs) - moveCursorLeft $ length $ lit rhs - - -renderLeft :: Blessings String -> IO () -renderLeft = putStr . pp - - -renderRight :: Blessings String -> IO () -renderRight a = do - saveCursor - moveCursorRight 1024 -- XXX obviously, this is a hack..^_^ - moveCursorLeft $ Blessings.length a - 1 - renderLeft a - unsaveCursor - - - -promptString :: Mode -> Blessings String -promptString NormalMode = SGR [33,1] "@ " -promptString InsertMode = "> " -promptString SelectRegisterMode = "\" " -promptString DeleteMode = SGR [31,1] "> " -promptString VerbatimMode = SGR [34,1] "^ " -promptString YankMode = SGR [31,1] "y " - - -spans :: (a -> Bool) -> [a] -> [Either [a] [a]] -spans p xs = f_r (span p_r xs) - where - p_r = not . p - p_l = p - f_r (as, bs) = Right as : if null bs then [] else f_l (span p_l bs) - f_l (as, bs) = Left as : if null bs then [] else f_r (span p_r bs) - - -gaudySpans :: Pm -> (Char -> Bool) -> String -> Blessings String -gaudySpans c p = - mconcat . map (either (SGR c . Plain . lit) Plain) . spans p - - -gaudySpecial :: Pm -> String -> Blessings String -gaudySpecial c = gaudySpans c (not . isPrint) - - -lit :: String -> String -lit = (>>= f) - where f '\ESC' = "^[" - f c = showLitChar c "" - - -clearLine :: IO () -clearLine = - putStr "\ESC[2K" >> - moveCursorLeft 1024 - - -ringBell :: IO () -ringBell = putStr "\x07" -- BEL '\a' - - -saveCursor :: IO () -saveCursor = putStr "\ESC[s" - -unsaveCursor :: IO () -unsaveCursor = putStr "\ESC[u" - - -moveCursorLeft :: Int -> IO () -moveCursorLeft 0 = return () -moveCursorLeft i = putStr $ "\ESC[" ++ show i ++ "D" - - -moveCursorRight :: Int -> IO () -moveCursorRight 0 = return () -moveCursorRight i = putStr $ "\ESC[" ++ show i ++ "C" - - --- TODO? charToCode c = "\\x" ++ showHex (ord c) -charToCode :: Char -> String -charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) "" - - -dmap :: Keymap -dmap = - [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing) - , ("\ESC[24~", DebugShowVTState) - , ("d", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("$", Yank ToEndOfLine <> - Delete ToEndOfLine <> - ChangeMode NormalMode <> - SetCount Nothing <> - MoveCursorLeftIfAtEndOfLine - ) - , ("0", Yank ToStartOfLine <> - Delete ToStartOfLine <> - ChangeMode NormalMode <> SetCount Nothing) - , ("h", Yank CharsBackward <> - Delete CharsBackward <> - ChangeMode NormalMode <> SetCount Nothing) - , ("l", Yank CharsForward <> - Delete CharsForward <> - ChangeMode NormalMode <> - SetCount Nothing <> - MoveCursorLeftIfAtEndOfLine - ) - ] - - -selectRegisterMap :: Keymap -selectRegisterMap = - [ ("\ESC", ChangeMode NormalMode) - ] - ++ (map (\c -> ([c], SetRegister c <> ChangeMode NormalMode)) - (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".%#:-\"")) - - --- TODO maybe in normal mode reset count (SetCount Nothing) after each --- command doesn't alter the count. How would this work together with --- ChangeMode DeleteMode --- TODO 2017-08-06 --- initialize count whenever nmap is entered --- ditch SetCount Nothing --- pass count to commands / modes -nmap :: Keymap -nmap = - [ ("\ESC", SetCount Nothing) - -- ^TODO RingBell if count is already Nothing - -- TODO cancel any unfinished commands - , ("i", ChangeMode InsertMode <> SetCount Nothing) - , ("a", ChangeMode InsertMode <> SetCount Nothing <> MoveCursor CharsForward) - , ("I", ChangeMode InsertMode <> MoveCursor ToStartOfLine) - , ("A", ChangeMode InsertMode <> MoveCursor ToEndOfLine) - , ("|", MoveCursorWarn ToColumn <> SetCount Nothing) - , ("$", MoveCursorWarn ToEndOfLine <> SetCount Nothing) - , ("h", MoveCursorWarn CharsBackward <> SetCount Nothing) - , ("l", MoveCursorWarn CharsForward <> SetCount Nothing) - , ("b", MoveCursorWarn WordsBackward <> SetCount Nothing) - , ("w", MoveCursorWarn WordsForward <> SetCount Nothing) - , ("d", ChangeMode DeleteMode) - , ("y", ChangeMode YankMode) - , ("\"", ChangeMode SelectRegisterMode <> SetCount Nothing) - , ("\ESC[24~", DebugShowVTState) - , ("\ESC[C", MoveCursorWarn CharsForward <> SetCount Nothing) - , ("\ESC[D", MoveCursorWarn CharsBackward <> SetCount Nothing) - , ("\n", ExecuteInputBuffer <> ChangeMode InsertMode <> SetCount Nothing) - ] - ++ (map (\i -> (show i, AppendCount i)) [0..9]) - -- XXX - -- if we would want 0 to move the cursor to the first character of the - -- line, then we would need ("0", x) - -- where - -- x :: Command - -- x = Embed f - -- f :: VT Command - -- f = gets (isJust . count) >>= - -- return . bool (MoveCursor ToStartOfLine) (AppendCount 0) - -- bool :: a -> a -> Bool -> a - -- bool _ a True = a - -- bool a _ False = a - -- and also we would have to extend data Command by Embed (VT Command) - -- execCommand (Embed a) = a >>= execCommand - -- - -- This all looks quite strange, so just use | if you want that movement... - -- ^_^ - - -imap :: Keymap -imap = - [ ("\ESC", ChangeMode NormalMode <> MoveCursor CharsBackward) - , ("\x01", MoveCursorWarn ToStartOfLine) - , ("\x05", MoveCursorWarn ToEndOfLine) - , ("\ESC[24~", DebugShowVTState) - , ("\ESC[3~", Delete CharsForward) - , ("\ESC[C", MoveCursorWarn CharsForward) - , ("\ESC[D", MoveCursorWarn CharsBackward) - , ("\x16", ChangeMode VerbatimMode) -- ^V - , ("\x17", Delete WordsBackward) -- ^W - , ("\x0a", ExecuteInputBuffer) - , ("\x7f", Delete CharsBackward) -- Delete - , ("\x08", Delete CharsBackward) -- BackSpace - , ("\ESCOc", MoveCursorWarn WordsForward) - , ("\ESCOd", MoveCursorWarn WordsBackward) - ] - -ymap :: Keymap -ymap = - [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing) - , ("\ESC[24~", DebugShowVTState) - -- TODO , ("y", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("$", Yank ToEndOfLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("0", Yank ToStartOfLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("h", Yank CharsBackward <> ChangeMode NormalMode <> SetCount Nothing) - , ("l", Yank CharsForward <> ChangeMode NormalMode <> SetCount Nothing) - ] - - -type Keymap = [(String, Command)] - - -getCommand :: Mode -> String -> Command - -getCommand InsertMode s = maybe (InsertString s) id $ lookup s imap - -getCommand NormalMode s = - maybe (AlertBadInput s <> SetCount Nothing) id $ lookup s nmap - -getCommand VerbatimMode s = InsertString s <> ChangeMode InsertMode - -getCommand SelectRegisterMode s = - maybe (AlertBadInput s) id $ lookup s selectRegisterMap - -- ^ TODO clear bad input - -getCommand DeleteMode s = maybe (AlertBadInput s) id $ lookup s dmap - -getCommand YankMode s = maybe (AlertBadInput s) id $ lookup s ymap - - --- TODO Control.Monad.whenLeft -whenLeft :: Monad m => Either a b -> (a -> m ()) -> m () -whenLeft (Left x) f = f x -whenLeft _ _ = return () - -whenM :: Monad m => m Bool -> m () -> m () -whenM a b = a >>= flip when b - -infixl 1 >>&& - -(>>&&) :: Monad m => m Bool -> m Bool -> m Bool -a >>&& b = do - ra <- a - rb <- b - return $ ra && rb - - -padl :: Int -> a -> [a] -> [a] -padl n c s - | length s < n = padl n c (c : s) - | otherwise = s diff --git a/src/Process.hs b/src/Process.hs deleted file mode 100644 index 41ea113..0000000 --- a/src/Process.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Process - ( spawn - , module System.Process - ) where - -import Control.Concurrent -import Control.Monad (unless, when) -import Data.Monoid -import System.Exit -import System.IO -import System.Process - -import Blessings -import Blessings.String () - - -type OutputWrapper = IO () -> IO () - -data OutStreamType = Stderr | Stdout - -color :: OutStreamType -> Ps -color Stderr = 31 -color Stdout = 32 - -data ReaperConfig = ReaperConfig - { withOutput :: OutputWrapper - , jobName :: String - , openFdsRef :: MVar Int - , processHandle :: ProcessHandle - , streamHandle :: Handle - , streamType :: OutStreamType - } - - -spawn :: Int -> OutputWrapper -> String -> IO () -spawn jobId _withOutput cmdline = do - - -- TODO stdin - (Nothing, Just hOut, Just hErr, ph) <- - createProcess (shell cmdline) - { std_in = Inherit -- TODO close - , std_out = CreatePipe - , std_err = CreatePipe - } - - _openFdsRef <- newMVar 2 - - let rcOut = ReaperConfig - { streamType = Stdout - , streamHandle = hOut - , withOutput = _withOutput - , jobName = '&' : show jobId - , openFdsRef = _openFdsRef - , processHandle = ph - } - rcErr = rcOut - { streamType = Stderr - , streamHandle = hErr - } - - forkIO $ reap rcOut - reap rcErr - - -reap :: ReaperConfig -> IO () -reap rc@ReaperConfig{..} = do - forLines_ streamHandle $ \line -> - withOutput $ putStrLn $ pp $ - SGR [35] (Plain jobName) <> - Plain " " <> - SGR [color streamType] (Plain line) - - i <- decMVar openFdsRef - - --withOutput $ - -- putStrLn $ "\x1b[35m" ++ name ++ "\x1b[m eof" - - when (i == 0) $ finish rc - - hClose streamHandle - myThreadId >>= killThread - - -finish :: ReaperConfig -> IO () -finish ReaperConfig{..} = do - exitCode <- waitForProcess processHandle - when (exitCode /= ExitSuccess) $ - withOutput $ putStrLn $ pp $ - SGR [35] (Plain jobName) <> - Plain " " <> - SGR [31] (Plain $ show exitCode) - - -decMVar :: MVar Int -> IO Int -decMVar = - flip modifyMVar dec - where - dec i = let i' = i - 1 in return (i', i') - - - --- TODO move utilities somewhere else -forLines_ :: Handle -> (String -> IO ()) -> IO () -forLines_ h f = rec - where - rec = hIsEOF h >>= flip unless (hGetLine h >>= f >> rec) -- cgit v1.2.3