trackit 0.4 → 0.5
raw patch · 4 files changed
+245/−92 lines, 4 filesdep ~base
Dependency ranges changed: base
Files
- README.md +18/−0
- src/Main.hs +212/−89
- src/ParseANSI.hs +13/−1
- trackit.cabal +2/−2
README.md view
@@ -35,6 +35,16 @@ The stabilization period can be set in milliseconds using the `--stabilization` flag. A lower value gives quicker response times, but increases the risk of getting spurious updates when a tight sequence changes occurs in the watched directory. The default stabilization period is 200 ms. +### Incremental output++The flag `--incremental` can be used to see partial output from slow commands. It will show the output line by line. Note, however, that each new line causes the display to be redrawn. This can lead to unnecessary flickering for fast outputs.++Here is an example demonstrating the incremental feature:++ trackit -i -c 'echo 1 && sleep 0.2 && echo 2 && sleep 0.2 && echo 3 && sleep 0.2 && echo 4 && sleep 0.2 && echo 5 && sleep 0.2 && echo 6 && sleep 0.2 && echo 7 && sleep 0.2 && echo 8 && sleep 0.2 && echo 9 && sleep 0.2 && echo 10 && sleep 0.2 && echo 11 && sleep 0.2 && echo 12 && sleep 0.2 && echo 13 && sleep 0.2 && echo 14 && sleep 0.2 && echo 15'++If the output exceeds the height of the terminal, you might want to use the flag `--follow-tail` to automatically scroll to the end as new lines are generated.+ ## Comparison to `watch` `trackit` offers two main advantages over the similar tool [watch](https://linux.die.net/man/1/watch):@@ -48,6 +58,14 @@ 2. `trackit` supports scrolling, and keeps the scrolled view even if the output is updated. ## Tips and tricks++### Merging `stdout` and `stderr`++`trackit` only listens to `stdout` from the given command. This means that anything written to `stderr` will be ignored. In order to make sure that `stderr` is also captured, the two streams can be interleaved. This can be done by appending `2>&1` to the command (tested on Linux).++For example, the following will show an error message when run outside a Git repository:++ > trackit -c "git status 2>&1" ### `git status`
src/Main.hs view
@@ -1,4 +1,4 @@-module Main where+module Main (main) where import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)@@ -12,12 +12,14 @@ import Data.Version (showVersion) import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText import GHC.Generics (Generic) import System.Exit (exitSuccess)-import System.Process.ListLike (shell)+import System.IO (BufferMode (..))+import qualified System.Process.ListLike as Process import qualified System.Process.Text as Text -import System.FSNotify (eventTime, watchTree, withManager)+import System.FSNotify (eventTime, withManager) import qualified System.FSNotify as FSNotify import Options.Generic@@ -31,20 +33,30 @@ import qualified Paths_trackit as Trackit import ParseANSI +type LText = LText.Text+ data CmdOptions = CmdOptions { _watchDir :: Maybe FilePath <?> "Directory to watch for changes in (not sub-directories). Cannot be used together with '--watch-tree'." , _watchTree :: Maybe FilePath <?> "Directory tree to watch for changes in (including sub-directories). Cannot be used together with '--watch-dir'." , _command :: Maybe String <?> "Command to run" , _maxLines :: Maybe Int <?> "Maximum number of lines to show (default: 400)"+ , _followTail :: Bool <?> "Follow the tail of the generated output."+ , _showRunning :: Bool <?> "Display a message while the command is running."+ , _incremental :: Bool <?> "Allow output to be updated incrementally. Redraws the buffer for every output line, so should only be used for \+ \slow outputs. Implies '--show-running'." , _stabilization :: Maybe Int <?> "Minimal time (milliseconds) between any file event and the next command update (default: 200)" , _version :: Bool <?> "Print the version number" , _help :: Bool , _debug :: Bool <?> "Show debug information in the lower right corner" } deriving (Show, Generic) +-- `--show-running` is not on by default because it causes a quick flickering+-- for fast commands.+ shortName :: String -> Maybe Char shortName "_watchDir" = Just 'd' shortName "_watchTree" = Just 't'+shortName "_showRunning" = Just 'r' shortName "_debug" = Just 'g' shortName (_:c:_) = Just c shortName _ = Nothing@@ -63,6 +75,9 @@ { watchDir :: Maybe (FilePath, WatchDepth) , command :: Maybe String , maxLines :: Int+ , followTail :: Bool+ , showRunning :: Bool+ , incremental :: Bool , stabilization :: NominalDiffTime , debug :: Bool } deriving (Show, Generic)@@ -83,11 +98,14 @@ (Just d, Nothing) -> return $ Just (d, Single) (Nothing, Just t) -> return $ Just (t, Recursive) _ -> fail watchDirError- let command = unHelpful _command- maxLines = fromMaybe 400 $ unHelpful _maxLines- stabPerMs = fromMaybe 200 $ unHelpful _stabilization+ let command = unHelpful _command+ maxLines = fromMaybe 400 $ unHelpful _maxLines+ followTail = unHelpful _followTail+ showRunning = unHelpful _showRunning+ incremental = unHelpful _incremental+ stabPerMs = fromMaybe 200 $ unHelpful _stabilization stabilization = fromIntegral stabPerMs / 1000- debug = unHelpful _debug+ debug = unHelpful _debug return $ Options {..} ansiImage :: Text -> Image@@ -102,52 +120,100 @@ cxt <- getContext render (k cxt) --- | Limit the text to @n@ lines (because large buffers make the app slow)-limit :: Int -> Text -> Text-limit n t- | length ls > n = Text.unlines (take n ls ++ [pruningNotification])- | otherwise = t <> eof+-- | Create a bold line looking like this:+--+-- > ---------------- <info> ----------------+infoLine :: Text -> Text+infoLine info = Text.concat+ [ "\ESC[1m"+ , line1+ , " "+ , info+ , " "+ , line2+ , "\ESC[m"+ ] where- ls = Text.lines t- eof = "\ESC[1m---------- End of output ----------\ESC[m"- pruningNotification = Text.unwords- [ "\ESC[1m---------- Lines beyond"- , Text.pack (show n)- , "pruned ----------\ESC[m"- ]+ l = 38 - Text.length info+ line1 = Text.replicate (l `div` 2) "-"+ line2 = Text.replicate ((l+1) `div` 2) "-" -getStdOut :: (a, stdout, b) -> stdout-getStdOut (_, o, _) = o -helpText :: Text-helpText = Text.concat+-- | Limit the text to @n@ lines (because large buffers make the app slow)+limit :: Int -> [Text] -> [Text]+limit n ls = ls' ++ case rest of+ [] -> [eof]+ _ -> [pruningNotification]+ where+ (ls', rest) = splitAt n ls+ eof = infoLine "End of output"+ pruningNotification =+ infoLine $ Text.unwords ["Lines beyond", Text.pack (show n), "pruned"]++helpText :: [Text]+helpText = [ "No command provided. Run 'trackit --help' for help.\n\n" , "Press 'q' to exit this window." ] +concatChunks :: [Process.Chunk LText] -> LText+concatChunks cs = LText.concat [c | Process.Stdout c <- cs]+ -- I initially thought that there would be one chunk per line given the+ -- `LineBuffering` setting, but this doesn't seem to be the case. Hence+ -- `Text.lines` is needed on the result.+ --+ -- There is an instance of `readCreateProcessLazy` that can return+ -- `(ExitCode, LText, LText)` directly without any chunks. However, that+ -- instance doesn't seem to have the desired laziness.+ -- | Run the command provided by the user, or print a helpful text if no command -- was given-runCMD :: Options -> IO Text-runCMD Options {..} =- case command of- Nothing -> return helpText- Just cmd ->- limit maxLines . getStdOut <$>- Text.readCreateProcessWithExitCode (shell cmd) ""+runCMD :: Options -> IO [Text]+runCMD Options {..} = case command of+ Nothing -> return helpText+ Just cmd -> do+ (_, o, _) <- Text.readCreateProcessWithExitCode (Process.shell cmd) ""+ return $ limit maxLines $ Text.lines o +-- | Run the command provided by the user, or print a helpful text if no command+-- was given+--+-- The output is returned as a lazy list of lines.+runLazyCMD :: Options -> IO [Text]+runLazyCMD Options {..} = case command of+ Nothing -> return helpText+ Just cmd ->+ limit maxLines . map LText.toStrict . LText.lines . concatChunks <$>+ Process.readCreateProcessLazy+ (Process.shell cmd, LineBuffering, LineBuffering)+ ""+ -- | Case-insensitive key-press recognizer keyPressed :: Char -> BrickEvent n e -> Bool keyPressed c (VtyEvent (EvKey (KChar c') [])) = toLower c == toLower c' keyPressed _ _ = False data AppState = AppState- { theText :: Text+ { commandOutput :: [Text] -- ^ Lines in reverse+ , commandRunning :: Bool , updateCount :: Integer } deriving (Eq, Show) +-- | Explicit request to run the command and update output+data UpdateRequest = UpdateRequest+ deriving (Eq, Show)++data TrackitEvent+ = Running -- ^ An incremental command started running+ | Done -- ^ An incremental command is done+ | AddLine Text -- ^ An incremental command produced a line+ | UpdateBuffer [Text] -- ^ A non-incremental command finished with the given output+ deriving (Eq, Show)+ initState :: AppState initState = AppState- { theText = ""+ { commandOutput = []+ , commandRunning = False , updateCount = 0 } @@ -160,101 +226,158 @@ drawApp :: Options -> AppState -> [Widget View] drawApp Options {..} AppState {..} = concat [ guard debug >> pure debugWidget- , pure $ viewport TheView Both $ raw $ ansiImage theText+ , pure $+ viewport TheView Both $+ raw $ ansiImage $ Text.unlines $ reverse (runningInfo ++ commandOutput) ] where+ attr = defAttr `withForeColor` black `withBackColor` white++ runningInfo = if commandRunning then [infoLine "Command is running"] else []+ debugText = "Update count: " <> Text.pack (show updateCount)- debugAttr = defAttr `withForeColor` black `withBackColor` white debugWidget = withContext $ \cxt -> translateBy (Location (availWidth cxt - Text.length debugText, availHeight cxt - 1)) $- raw $ text' debugAttr debugText+ raw $ text' attr debugText withSize :: ((Int, Int) -> EventM View ()) -> EventM View () withSize k = mapM_ k . fmap extentSize =<< lookupExtent TheView -updateApp :: Options -> AppState -> EventM View (Next AppState)-updateApp opts s = do- newText <- liftIO $ runCMD opts- continue $ s {theText = newText, updateCount = updateCount s + 1}--stepApp :: Options -> AppState -> BrickEvent View () -> EventM View (Next AppState)-stepApp _ s (keyPressed 'q' -> True) = halt s-stepApp _ s (VtyEvent (EvKey KDown [])) = theView `vScrollBy` 1 >> continue s-stepApp _ s (VtyEvent (EvKey KUp [])) = theView `vScrollBy` (-1) >> continue s-stepApp _ s (VtyEvent (EvKey KLeft [])) = withSize (\(w, _) -> theView `hScrollBy` (negate $ div w 2)) >> continue s-stepApp _ s (VtyEvent (EvKey KRight [])) = withSize (\(w, _) -> theView `hScrollBy` (div w 2)) >> continue s-stepApp _ s (VtyEvent (EvKey KHome _)) = vScrollToBeginning theView >> continue s-stepApp _ s (VtyEvent (EvKey KEnd _)) = vScrollToEnd theView >> continue s-stepApp _ s (VtyEvent (EvKey KPageUp [])) = withSize (\(_, h) -> theView `vScrollBy` (negate h)) >> continue s-stepApp _ s (VtyEvent (EvKey KPageDown [])) = withSize (\(_, h) -> theView `vScrollBy` h) >> continue s-stepApp opts s (VtyEvent (EvKey (KChar ' ') _)) = updateApp opts s-stepApp opts s (AppEvent ()) = updateApp opts s-stepApp _ s _ = continue s+stepApp ::+ Options+ -> TVar (Maybe UpdateRequest)+ -> AppState+ -> BrickEvent View TrackitEvent+ -> EventM View (Next AppState)+stepApp _ _ s (keyPressed 'q' -> True) = halt s+stepApp _ _ s (VtyEvent (EvKey KDown [])) = theView `vScrollBy` 1 >> continue s+stepApp _ _ s (VtyEvent (EvKey KUp [])) = theView `vScrollBy` (-1) >> continue s+stepApp _ _ s (VtyEvent (EvKey KLeft [])) = withSize (\(w, _) -> theView `hScrollBy` (negate $ div w 2)) >> continue s+stepApp _ _ s (VtyEvent (EvKey KRight [])) = withSize (\(w, _) -> theView `hScrollBy` (div w 2)) >> continue s+stepApp _ _ s (VtyEvent (EvKey KHome _)) = vScrollToBeginning theView >> continue s+stepApp _ _ s (VtyEvent (EvKey KEnd _)) = vScrollToEnd theView >> continue s+stepApp _ _ s (VtyEvent (EvKey KPageUp [])) = withSize (\(_, h) -> theView `vScrollBy` (negate h)) >> continue s+stepApp _ _ s (VtyEvent (EvKey KPageDown [])) = withSize (\(_, h) -> theView `vScrollBy` h) >> continue s+stepApp _ updReq s (VtyEvent (EvKey (KChar ' ') _)) = do+ liftIO $ atomically $ writeTVar updReq (Just UpdateRequest)+ continue s+stepApp _ _ s (AppEvent Running) =+ continue s+ { commandOutput = []+ , commandRunning = True+ }+stepApp opts _ s (AppEvent Done) = do+ when (followTail opts) $ vScrollToEnd theView+ continue s+ { commandRunning = False+ , updateCount = updateCount s + 1+ }+stepApp opts _ s (AppEvent (AddLine line)) = do+ when (followTail opts) $ vScrollToEnd theView+ continue s+ { commandOutput = line : commandOutput s+ }+stepApp opts _ s (AppEvent (UpdateBuffer buf)) = do+ when (followTail opts) $ vScrollToEnd theView+ continue s+ { commandOutput = buf+ , commandRunning = False+ , updateCount = updateCount s + 1+ }+stepApp _ _ s _ = continue s -myApp :: Options -> App AppState () View-myApp opts =+myApp :: Options -> TVar (Maybe UpdateRequest) -> App AppState TrackitEvent View+myApp opts updReq = App { appDraw = drawApp opts- , appHandleEvent = stepApp opts+ , appHandleEvent = stepApp opts updReq , appStartEvent = return , appAttrMap = const $ attrMap defAttr [] , appChooseCursor = neverShowCursor } -appMain :: Options -> BChan () -> IO AppState-appMain opts updEv =- customMain (mkVty defaultConfig) (Just updEv) (myApp opts) initState+appMain ::+ Options -> TVar (Maybe UpdateRequest) -> BChan TrackitEvent -> IO AppState+appMain opts updReq updEv =+ customMain (mkVty defaultConfig) (Just updEv) (myApp opts updReq) initState --- | A loop that continuously looks for events in the 'TVar' and runs the given--- action whenever there's an event that occurred more than--- 'stabilization' seconds ago. Then the 'TVar' is emptied. If the event--- occurred less time ago, it will remain in the 'TVar' and processed in a later--- iteration (unless overwritten by another event meanwhile).-delayedUpdate ::+-- | A loop that continuously looks for events in the two variables and runs the+-- given action in response. The variables are emptied whenever the action runs.+--+-- Events in the second variable immediately trigger the action. For events in+-- the second variable, the action only happens if the event occurred more than+-- 'stabilization' seconds ago. If the event occurred less time ago, it will+-- remain in the variable and processed in a later iteration (unless emptied by+-- another event in the meantime).+worker :: Options -> TVar (Maybe FSNotify.Event) -- ^ Variable holding the last file event that has not yet been processed+ -> TVar (Maybe UpdateRequest)+ -- ^ Variable holding a potential update request -> IO () -- ^ Action to perform when the file event has stabilized -> IO ()-delayedUpdate Options {..} lastFSEv action =+worker Options {..} lastFSEv updReq action = forever $ do threadDelay loopPeriod t <- getCurrentTime act <- atomically $ do- mfsEv <- readTVar lastFSEv- case mfsEv of- Nothing -> return False- Just fsEv -> do- let stable = diffUTCTime t (eventTime fsEv) >= stabilization- when stable $ writeTVar lastFSEv Nothing- return stable+ mupd <- readTVar updReq+ case mupd of+ Just UpdateRequest -> resetEvents >> return True+ Nothing -> do+ mfsEv <- readTVar lastFSEv+ case mfsEv of+ Nothing -> return False+ Just fsEv -> do+ let stable = diffUTCTime t (eventTime fsEv) >= stabilization+ when stable resetEvents+ return stable when act action where+ resetEvents = do+ writeTVar lastFSEv Nothing+ writeTVar updReq Nothing loopPeriod = max 10000 $ round (stabilization * 1e6 / 5) -- Cap at 10 ms to avoid making the loop too busy when the stabilization -- period is small. +-- | Run the command and feed the output lines to the GUI+updater :: Options -> BChan TrackitEvent -> IO ()+updater opts@Options {..} updEv+ | incremental = do+ writeBChan updEv Running+ ls <- runLazyCMD opts+ mapM_ (writeBChan updEv . AddLine) ls+ writeBChan updEv Done+ | otherwise = do+ when showRunning $ writeBChan updEv Running+ ls <- runCMD opts+ writeBChan updEv $ UpdateBuffer $ reverse ls+ main = do opts@Options {..} <- getOptions- lastFSEv <- newTVarIO Nothing -- Channel holding the last file event- updEv <- newBChan 1 -- Channel for GUI update events- let setEvent ev = atomically $ writeTVar lastFSEv $ Just ev- update = writeBChan updEv ()- update -- Force initial GUI update- case watchDir of- Nothing -> void $ appMain opts updEv- Just (path, depth) -> do- tid <- forkIO $ delayedUpdate opts lastFSEv update+ -- Channel holding the last file event+ lastFSEv <- newTVarIO Nothing+ -- Channel holding user update requests (set to request an initial update)+ updReq <- newTVarIO (Just UpdateRequest)+ -- Channel for GUI update events+ updEv <- newBChan 1+ let setFsEvent ev = atomically $ writeTVar lastFSEv $ Just ev+ tid <- forkIO $ worker opts lastFSEv updReq (updater opts updEv)+ void $ case watchDir of+ Nothing -> appMain opts updReq updEv+ Just (path, depth) -> withManager $ \m -> do void $ case depth of- Single -> FSNotify.watchDir m path (const True) setEvent- Recursive -> watchTree m path (const True) setEvent- void $ appMain opts updEv- killThread tid+ Single -> FSNotify.watchDir m path (const True) setFsEvent+ Recursive -> FSNotify.watchTree m path (const True) setFsEvent+ appMain opts updReq updEv+ killThread tid -- Note: The "debouncing" option of fsnotify makes it so that only the *first* -- in a tight series of events is reported. However, this is problematic since@@ -266,6 +389,6 @@ -- -- In contrast, the approach taken here is to react to the *last* in a tight -- sequence of events. A tight sequence is defined as a sequence in which each--- consecutive pair of events have a time distance of less than--- `stabilization` seconds. And since `delayedUpdate` runs continuously, there's--- never a risk that an event will be missed.+-- consecutive pair of events has a time distance of less than `stabilization`+-- seconds. And since `worker` runs continuously, there's never a risk that an+-- event will be missed.
src/ParseANSI.hs view
@@ -11,6 +11,18 @@ import Graphics.Vty.Attributes +-- | A tab character represented as a number of spaces+tab :: Text+tab = Text.replicate tabLength " "+ where+ tabLength = 8++-- | Convert all tab characters to spaces+convTabs :: Text -> Text+convTabs = Text.concatMap $ \c -> case c of+ '\t' -> tab+ _ -> Text.singleton c+ readMay :: Read a => Text -> Maybe a readMay t = case reads $ Text.unpack t of [(a, "")] -> Just a@@ -72,7 +84,7 @@ -- | Parse a text containing ANSI control codes parseANSI :: Text -> [Segment]-parseANSI = map parseSegment . onHead fixHead . Text.splitOn esc+parseANSI = map parseSegment . onHead fixHead . Text.splitOn esc . convTabs where -- Ensure that the text starts with an escape code fixHead :: Text -> Text
trackit.cabal view
@@ -1,5 +1,5 @@ name: trackit-version: 0.4+version: 0.5 synopsis: A command-line tool for live monitoring description: @trackit@ is a command-line tool that listens for changes in a user-supplied directory. Whenever there is a change,@@ -40,7 +40,7 @@ main-is: Main.hs other-modules: Paths_trackit ParseANSI- build-depends: base >=4.10 && <4.11,+ build-depends: base >=4.10 && <4.13, brick, fsnotify, mtl,