From e3c8479127589b05719567f6821383ad0d9f5b27 Mon Sep 17 00:00:00 2001 From: tv Date: Mon, 28 Jul 2014 14:18:39 +0200 Subject: move source to src/ --- src/Buffer.hs | 7 + src/Buffer/Class.hs | 13 ++ src/Buffer/Motion.hs | 83 ++++++++ src/Main.hs | 554 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/Process.hs | 98 +++++++++ 5 files changed, 755 insertions(+) create mode 100644 src/Buffer.hs create mode 100644 src/Buffer/Class.hs create mode 100644 src/Buffer/Motion.hs create mode 100644 src/Main.hs create mode 100644 src/Process.hs (limited to 'src') diff --git a/src/Buffer.hs b/src/Buffer.hs new file mode 100644 index 0000000..43d222e --- /dev/null +++ b/src/Buffer.hs @@ -0,0 +1,7 @@ +module Buffer + ( module Buffer.Class + , module Buffer.Motion + ) where + +import Buffer.Class +import Buffer.Motion diff --git a/src/Buffer/Class.hs b/src/Buffer/Class.hs new file mode 100644 index 0000000..75664a5 --- /dev/null +++ b/src/Buffer/Class.hs @@ -0,0 +1,13 @@ +-- TODO Class is a lie +module Buffer.Class where + + +type Buffer = (String, String) + +emptyBuffer :: Buffer +emptyBuffer = ("", "") + + +-- TODO instance Show Buffer (w/newtype Buffer) (?) +showBuffer :: Buffer -> String +showBuffer (lhs, rhs) = lhs ++ rhs diff --git a/src/Buffer/Motion.hs b/src/Buffer/Motion.hs new file mode 100644 index 0000000..fa9e059 --- /dev/null +++ b/src/Buffer/Motion.hs @@ -0,0 +1,83 @@ +module Buffer.Motion where + +import Data.List (dropWhileEnd) +import Buffer.Class + +--data Motion = Motion Int LeftRightMotion + + +-- TODO factor Count +-- TODO various Vim gX +data LeftRightMotion + = GotoLeft Int + | GotoRight Int + | GotoFirstChar + -- | GotoFirstNonBlankChar + | GotoEndOfLine -- XXX in Vi this can go downwards + | GotoColumn Int + -- | GotoFindLeft Int (Char -> Bool) -- TODO don't use functions here + -- | GotoFindRight Int (Char -> Bool) -- TODO ^ dto. + -- | GotillFindLeft Int Char + -- | GotillFindRight Int Char + -- | RepeatLastFind Int + -- | RepeatLastFindReverse Int + | WordsForward Int + | WordsBackward Int + deriving (Show) + + +-- TODO fail if cannot splitAt properly OR if we didn't modify the buffer +gotoLeft :: Int -> Buffer -> Buffer +gotoLeft i (ls, rs) = + let (lls, rls) = splitAt (length ls - i) ls in (lls, rls ++ rs) + + +-- TODO fail if cannot splitAt properly OR if we didn't modify the buffer +gotoRight :: Int -> Buffer -> Buffer +gotoRight i (ls, rs) = + let (lrs, rrs) = splitAt i rs in (ls ++ lrs, rrs) + + +gotoFirstChar :: Buffer -> Buffer +gotoFirstChar (ls, rs) = ("", ls ++ rs) + + +gotoEndOfLine :: Buffer -> Buffer +gotoEndOfLine (ls, rs) = (ls ++ rs, "") + + +-- TODO fail if i <= 0 or i > length +gotoColumn :: Int -> Buffer -> Buffer +gotoColumn i (ls, rs) = splitAt (i - 1) $ ls ++ rs + + +wordsForward :: Int -> Buffer -> Buffer +wordsForward i (ls, rs) = + let rs' = dropWhile (==' ') $ dropWhile (/=' ') rs + ls' = ls ++ take (length rs - length rs') rs + b' = (ls', rs') + in + if i > 1 + then wordsForward (i - 1) b' + else b' + + +wordsBackward :: Int -> Buffer -> Buffer +wordsBackward i (ls, rs) = + let ls' = dropWhileEnd (/=' ') $ dropWhileEnd (==' ') ls + rs' = drop (length ls') ls ++ rs + b' = (ls', rs') + in + if i > 1 + then wordsBackward (i - 1) b' + else b' + + +move :: LeftRightMotion -> Buffer -> Buffer +move (GotoLeft i) = gotoLeft i +move (GotoRight i) = gotoRight i +move GotoFirstChar = gotoFirstChar +move GotoEndOfLine = gotoEndOfLine +move (GotoColumn i) = gotoColumn i +move (WordsForward i) = wordsForward i +move (WordsBackward i) = wordsBackward i diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..43ff393 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Main where + +import Control.Applicative +import Control.Concurrent +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 + +import GHC.Stats (getGCStats) + +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer + +import Buffer +import Process + +data VTConfig = VTConfig + { withOutput :: IO () -> IO () + } + +data VTState = VTState + { buffer :: Buffer + , mode :: Mode + , processCount :: Int + } + +main :: IO () +main = do + hSetEcho stdin False + hSetBuffering stdin NoBuffering + + -- WINCH + -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing + + let st = VTState + { mode = InsertMode + , buffer = ("", "") + , processCount = 0 + } + + 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 (mode q) (buffer q) + hFlush stdout + + let cf = VTConfig + { withOutput = _withOutput + } + + -- render initial input line + _withOutput $ return () + + forkIO $ dateThread _withOutput 1000000 + + uiThread cf _putState _getState + + +dateThread :: (IO () -> IO ()) -> Int -> IO () +dateThread _withOutput delay = forever $ do + t <- liftIO getCurrentTime + _withOutput $ + putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t + threadDelay delay + + +uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO () +uiThread cf putState getState = forever $ do + q0 <- getState + + ((eitCmd, lns), q1) <- runVT cf q0 $ do + c <- getCommand (mode q0) + execCommand c + return c + + -- TODO only putState if it has changed (?) + putState q1 + + let mbErr = case eitCmd of + Left err -> Just err + Right c -> + -- TODO move this to execCommand / throwError + case c of + MotionCommand motion | buffer q0 == buffer q1 -> + Just (OtherError $ "motion failed: " ++ show motion) + _ -> + Nothing + + withOutput cf $ do + forM_ lns putStrLn + + case mbErr of + Just err -> ringBell >> putStrLn (prettyError err) + Nothing -> return () + + --when (mode st /= mode st') $ do + -- putStrLn $ "change mode: " ++ (show $ mode st') + + + +data Command + = AlertBadInput String + | InsertString String + | KillLastWord + | KillLastChar + | KillNextChar + | ExecuteInputBuffer + | MotionCommand LeftRightMotion + | ChangeMode Mode + -- TODO Move Count Motion + -- Delete Count Register Motion + -- etc. + | Combine Command Command + | Nop + | RingBell + +instance Monoid Command where + mempty = Nop + mappend = Combine + + + +data ExecError + = UnhandledInputError String + | OtherError String + +instance Error ExecError where + noMsg = OtherError "something went wrong" + +prettyError :: ExecError -> String +prettyError e = rec e + where + color cc s = "\x1b[" ++ cc ++ "m" ++ s ++ "\x1b[m" + + rec (UnhandledInputError s) = + color "31" $ "unhandled input: <" ++ (pp "31;1" s) ++ "\x1b[;31m>" + + rec (OtherError s) = + color "31" $ "error: " ++ s + + -- TODO cc is ColorCode + pp cc = concat . map (pp1 cc) + pp1 cc c + | isPrint c = [c] + | otherwise = specialChar cc $ + case c of + '\x1b' -> "^[" + _ -> charToCode c + specialChar cc s = "\x1b[1;35m" ++ s ++ "\x1b[;" ++ cc ++ "m" + + + + +modifyBuffer :: (Buffer -> Buffer) -> VT () +modifyBuffer f = + modify $ \st -> st { buffer = f (buffer st) } + + + +newtype VT a = VT + (ReaderT VTConfig + (ErrorT 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 (runErrorT (runReaderT a cf))) st + + + +insertString :: String -> Buffer -> Buffer +insertString s (ls, rs) = (ls ++ s, rs) + + +execCommand :: Command -> VT () + +execCommand (MotionCommand x) = do + modifyBuffer (move x) + -- TODO apply mode constraints somewhere else + q <- get + when (mode q == NormalMode) $ + when (null $ snd $ buffer q) $ + modifyBuffer (gotoLeft 1) + +execCommand (ChangeMode m) = + modify $ \ q -> q { mode = m } + +execCommand (InsertString s) = + modifyBuffer (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 + ":s" -> do + s <- liftIO getGCStats + tell [ show s ] + '!' : cmdline -> do + --tell [ "spawn: " ++ cmdline ] + -- "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ] + -- TODO register process + i <- state $ \ q -> + let i = processCount q + 1 + in (i, q { processCount = i }) + cf <- ask + liftIO $ forkIO $ spawn i (withOutput cf) cmdline + return () + "" -> do + liftIO ringBell + s -> do + tell [ "input: <" ++ (concat $ map (reform 32) s) ++ ">" ] + + modifyBuffer (const emptyBuffer) + +execCommand KillNextChar = do + get >>= flip (when . null . snd . buffer) + (throwError $ OtherError "nothing to kill right") + modifyBuffer $ \(lhs, _:rhs') -> (lhs, rhs') + +execCommand KillLastChar = do + get >>= flip (when . null . fst . buffer) + (throwError $ OtherError "nothing to kill left") + modifyBuffer $ \(lhs, rhs) -> (init lhs, rhs) + +execCommand KillLastWord = do + get >>= flip (when . null . fst . buffer) + (throwError $ OtherError "nothing to kill left") + modifyBuffer $ + \(lhs, rhs) -> (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs) + +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 + + +reform :: Int -> Char -> String +reform colorCode c = + if isPrint c + then normal colorCode [c] + else + special colorCode $ + case ord c of + 27 -> "^[" + _ -> charToCode c + +normal :: Int -> String -> String +normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m" + +special :: Int -> String -> String +special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m" + + + +-- XXX assumes that the cursor is already at the (cleared) input line +renderInputLine :: Mode -> Buffer -> IO () +renderInputLine m (lhs, rhs) = do + clearLine -- TODO this is required for drawing the mode on the right side + saveCursor + moveCursorRight 1024 + moveCursorLeft (length (show m) - 1) + putStr $ "\x1b[1;30m" ++ show m ++ "\x1b[m" + unsaveCursor + + let promptString = case m of + NormalMode -> "\x1b[33;1m@\x1b[m " + InsertMode -> "> " + VerbatimMode -> "\x1b[34;1m^\x1b[m " + + putStr $ promptString ++ pp lhs ++ pp rhs + moveCursorLeft (length $ ppVis rhs) + where + pp = concat . map reform' + + -- TODO unify reform and reform' + reform' c = + if isPrint c + then [c] + else + "\x1b[35m" ++ ( + case ord c of + 27 -> "^[" + _ -> charToCode c + ) ++ "\x1b[m" + + ppVis = concat . map reformVis + reformVis c = + if isPrint c + then [c] + else + case ord c of + 27 -> "^[" + _ -> charToCode c + + + + + + +clearLine :: IO () +clearLine = + putStr "\x1b[2K" >> + moveCursorLeft 1024 + + +ringBell :: IO () +ringBell = putStr "\x07" -- BEL '\a' + + +saveCursor :: IO () +saveCursor = putStr "\x1b[s" + +unsaveCursor :: IO () +unsaveCursor = putStr "\x1b[u" + + +moveCursorLeft :: Int -> IO () +moveCursorLeft 0 = return () +moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D" + + +moveCursorRight :: Int -> IO () +moveCursorRight 0 = return () +moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C" + + +-- TODO? charToCode c = "\\x" ++ showHex (ord c) +charToCode :: Char -> String +charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) "" + + + +nmap :: Keymap +nmap = + [ ("i", ChangeMode InsertMode) + , ("a", ChangeMode InsertMode <> MotionCommand (GotoRight 1)) + , ("I", ChangeMode InsertMode <> MotionCommand GotoFirstChar) + , ("A", ChangeMode InsertMode <> MotionCommand GotoEndOfLine) + , ("0", MotionCommand GotoFirstChar) + , ("$", MotionCommand GotoEndOfLine) + , ("h", MotionCommand $ GotoLeft 1) + , ("l", MotionCommand $ GotoRight 1) + , ("b", MotionCommand $ WordsBackward 1) + , ("w", MotionCommand $ WordsForward 1) + , ("\x1b[C", MotionCommand $ GotoRight 1) + , ("\x1b[D", MotionCommand $ GotoLeft 1) + , ("\x0a", ExecuteInputBuffer <> ChangeMode InsertMode) + , ("\x1b", RingBell) -- TODO cancel any unfinished commands + ] + + +imap :: Keymap +imap = + [ ("\x1b", ChangeMode NormalMode <> MotionCommand (GotoLeft 1)) + , ("\x01", MotionCommand GotoFirstChar) + , ("\x05", MotionCommand GotoEndOfLine) + , ("\x1b[3~", KillNextChar) + , ("\x1b[C", MotionCommand $ GotoRight 1) + , ("\x1b[D", MotionCommand $ GotoLeft 1) + , ("\x16", ChangeMode VerbatimMode) -- ^V + , ("\x17", KillLastWord) -- ^W + , ("\x0a", ExecuteInputBuffer) + , ("\x7f", KillLastChar) -- Delete + , ("\x08", KillLastChar) -- BackSpace + , ("\x1bOc", MotionCommand $ WordsForward 1) + , ("\x1bOd", MotionCommand $ WordsBackward 1) + ] + + +type Keymap = [(String, Command)] + +data Mode + = InsertMode + | NormalMode + | VerbatimMode + deriving (Eq) + +instance Show Mode where + show NormalMode = "normal" + show InsertMode = "insert" + show VerbatimMode = "verbatim" + + +getCommand :: Mode -> VT Command +getCommand InsertMode = getCommandXXX imap InsertString +getCommand NormalMode = getCommandXXX nmap AlertBadInput +getCommand VerbatimMode = verbatimKeymap + + +-- TODO refactor me please^_^ +getCommandXXX :: Keymap -> (String -> Command) -> VT Command +getCommandXXX keymap defCmd = do + + -- wait for the first character + _ <- liftIO $ hLookAhead stdin + + bufRef <- liftIO $ newIORef "" + candRef <- liftIO $ newIORef Nothing + cmdRef <- liftIO $ newEmptyMVar -- :: MVar (Maybe (String -> Command)) + + -- TODO ensure that this thread dies eventually + --forkIO $ rec "" keymap cmdRef candRef + getCharThreadId <- + --forkFinally (rec keymap cmdRef candRef bufRef) + -- (\_ -> putStrLn "input terminated") + liftIO $ forkIO $ do + rec keymap cmdRef candRef bufRef + + watchDogThreadId <- + liftIO $ forkIO $ do + --putStrLn "watchdog activated" + threadDelay $ 1000 * 50 -- 50ms + --putStrLn "watchdog timeout" + killThread getCharThreadId + --putStrLn "watchdog killed getCharThread" + putMVar cmdRef Nothing -- continue main thread + + mbCmd <- liftIO $ takeMVar cmdRef + + liftIO $ killThread watchDogThreadId + + cmd <- case mbCmd of + Just cmd -> return cmd + Nothing -> do + mbCmd2 <- liftIO $ readIORef candRef + case mbCmd2 of + Just cmd2 -> return cmd2 + Nothing -> return defCmd + + s <- liftIO $ readIORef bufRef + + --clearLine + --putStrLn $ "\x1b[35;1m" ++ (show s) ++ " -> " ++ (show $ cmd s) ++ "\x1b[m" + return $ cmd s + + where + rec :: Keymap + -> MVar (Maybe (String -> Command)) + -> IORef (Maybe (String -> Command)) + -> IORef String + -> IO () + rec km cmdRef candRef bufRef = do + c <- getChar + -- TODO s <- atomicModifyIORef bufRef $ \s -> let s' = s++[c] in (s,s) + olds <- readIORef bufRef + let s = olds ++ [c] + writeIORef bufRef s + + let km' = map (\(str,cmd) -> (tail str, cmd)) + $ filter ((==c) . head . fst) km + + -- direct and indirect candidates + (dc, ic) = partition (null . fst) km' + + --clearLine + --putStrLn $ " s: " ++ show s + --putStrLn $ "ic: " ++ (show $ map snd ic) + --putStrLn $ "dc: " ++ (show $ map snd dc) + + -- update candidate + if length dc == 1 + then atomicWriteIORef candRef (Just $ const $ snd $ dc !! 0) + else atomicWriteIORef candRef Nothing + + case length km' of + 0 -> do + --return $ defCmd' (s ++ [c]) + cand <- readIORef candRef + putMVar cmdRef cand + 1 -> + let (rest, cmd) = km' !! 0 + in if null rest + then do + --return $ cmd + -- TODO somehow give s? + putMVar cmdRef (Just $ const cmd) + else do + --rec (s ++ [c]) ic defCmd' + rec ic cmdRef candRef bufRef + _ -> do + --rec (s ++ [c]) ic defCmd' + rec ic cmdRef candRef bufRef + + + +verbatimKeymap :: VT Command +verbatimKeymap = do + c <- liftIO getChar + return $ InsertString [c] <> ChangeMode InsertMode + + +-- TODO Control.Monad.whenLeft +whenLeft :: Monad m => Either a b -> (a -> m ()) -> m () +whenLeft (Left x) f = f x +whenLeft _ _ = return () + + diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 index 0000000..5c53681 --- /dev/null +++ b/src/Process.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE RecordWildCards #-} +module Process + ( spawn + , module System.Process + ) where + +import Control.Monad (unless, when) +import System.IO +import System.Process +import Control.Concurrent + +type OutputWrapper = IO () -> IO () + +data OutStreamType = Stderr | Stdout + +color :: OutStreamType -> String +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 $ do + putStrLn $ + "\x1b[35m" ++ jobName ++ "\x1b[m " ++ + "\x1b[" ++ (color streamType) ++ "m" ++ line ++ "\x1b[m" + + 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 + withOutput $ + putStrLn $ "\x1b[35m" ++ jobName ++ "\x1b[m exit: " ++ 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