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/ --- Buffer.hs | 7 - Buffer/Class.hs | 13 -- Buffer/Motion.hs | 83 -------- Main.hs | 554 --------------------------------------------------- Process.hs | 98 --------- hack.cabal | 1 + src/Buffer.hs | 7 + src/Buffer/Class.hs | 13 ++ src/Buffer/Motion.hs | 83 ++++++++ src/Main.hs | 554 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/Process.hs | 98 +++++++++ 11 files changed, 756 insertions(+), 755 deletions(-) delete mode 100644 Buffer.hs delete mode 100644 Buffer/Class.hs delete mode 100644 Buffer/Motion.hs delete mode 100644 Main.hs delete mode 100644 Process.hs 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 diff --git a/Buffer.hs b/Buffer.hs deleted file mode 100644 index 43d222e..0000000 --- a/Buffer.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Buffer - ( module Buffer.Class - , module Buffer.Motion - ) where - -import Buffer.Class -import Buffer.Motion diff --git a/Buffer/Class.hs b/Buffer/Class.hs deleted file mode 100644 index 75664a5..0000000 --- a/Buffer/Class.hs +++ /dev/null @@ -1,13 +0,0 @@ --- 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/Buffer/Motion.hs b/Buffer/Motion.hs deleted file mode 100644 index fa9e059..0000000 --- a/Buffer/Motion.hs +++ /dev/null @@ -1,83 +0,0 @@ -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/Main.hs b/Main.hs deleted file mode 100644 index 43ff393..0000000 --- a/Main.hs +++ /dev/null @@ -1,554 +0,0 @@ -{-# 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/Process.hs b/Process.hs deleted file mode 100644 index 5c53681..0000000 --- a/Process.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# 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) diff --git a/hack.cabal b/hack.cabal index 13e26e6..acfcae4 100644 --- a/hack.cabal +++ b/hack.cabal @@ -11,6 +11,7 @@ Build-type: Simple Cabal-version: >=1.2 Executable hack + hs-source-dirs: src main-is: Main.hs Build-depends: 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