summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Buffer.hs7
-rw-r--r--src/Buffer/Class.hs13
-rw-r--r--src/Buffer/Motion.hs83
-rw-r--r--src/Main.hs554
-rw-r--r--src/Process.hs98
5 files changed, 755 insertions, 0 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-28 22:13:42 +0000