diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Main.hs | 633 | ||||
| -rw-r--r-- | app/Process.hs | 108 |
2 files changed, 741 insertions, 0 deletions
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{..} = + "<VTState" + ++ " buffer=" ++ show _buffer + ++ " mode=" ++ show _mode + ++ " processCount=" ++ show _processCount + ++ " count=" ++ show (maybe 0 id _count) + ++ " register=" ++ show _register + ++ " registers=" ++ show _registers + ++ ">" + +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) |