diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,18 @@ +concurrent-output (1.6.0) unstable; urgency=medium + + * Generalized newConsoleRegion. + * Better efficiency when there are more regions than will fit on the + screen. + * Fixed consoleHeight (was returning width) + * Fix outputBufferWaiterSTM which never returned any buffered stderr, + and fix regional display of buffered error messages. + * Ported to Windows, although createProcessConcurrent is omitted due to + needing support for pipe(), and consoleSize is not updated by resize. + * Stopped exporting consoleSize; use consoleWidth and consoleHeight + instead. + + -- Joey Hess Thu, 05 Nov 2015 15:35:16 -0400 + concurrent-output (1.5.0) unstable; urgency=medium * Added errorConcurrent. diff --git a/System/Console/Concurrent.hs b/System/Console/Concurrent.hs --- a/System/Console/Concurrent.hs +++ b/System/Console/Concurrent.hs @@ -14,6 +14,8 @@ -- > `concurrently` -- > createProcessConcurrent (proc "ls" []) +{-# LANGUAGE CPP #-} + module System.Console.Concurrent ( -- * Concurrent output withConcurrentOutput, @@ -21,7 +23,9 @@ outputConcurrent, errorConcurrent, ConcurrentProcessHandle, +#ifndef mingw32_HOST_OS createProcessConcurrent, +#endif waitForProcessConcurrent, createProcessForeground, flushConcurrentOutput, diff --git a/System/Console/Concurrent/Internal.hs b/System/Console/Concurrent/Internal.hs --- a/System/Console/Concurrent/Internal.hs +++ b/System/Console/Concurrent/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} +{-# LANGUAGE CPP #-} -- | -- Copyright: 2015 Joey Hess @@ -11,7 +12,9 @@ module System.Console.Concurrent.Internal where import System.IO +#ifndef mingw32_HOST_OS import System.Posix.IO +#endif import System.Directory import System.Exit import Control.Monad @@ -253,6 +256,9 @@ -- the process is instead run with its stdout and stderr -- redirected to a buffer. The buffered output will be displayed as soon -- as the output lock becomes free. +-- +-- Currently only available on Unix systems, not Windows. +#ifndef mingw32_HOST_OS createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) createProcessConcurrent p | willOutput (P.std_out p) || willOutput (P.std_err p) = @@ -265,6 +271,7 @@ asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h return (toConcurrentProcessHandle r) +#endif -- | Wrapper around `System.Process.createProcess` that makes sure a process -- is run in the foreground, with direct access to stdout and stderr. @@ -284,6 +291,7 @@ dropOutputLock return (toConcurrentProcessHandle r) +#ifndef mingw32_HOST_OS bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) bgProcess p = do (toouth, fromouth) <- pipe @@ -307,6 +315,7 @@ rediroutput ss h | willOutput ss = P.UseHandle h | otherwise = ss +#endif willOutput :: P.StdStream -> Bool willOutput P.Inherit = True @@ -483,19 +492,16 @@ -- -- This will prevent it from being displayed in the usual way, so you'll -- need to use `emitOutputBuffer` to display it yourself. -outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM [(StdHandle, OutputBuffer)] -outputBufferWaiterSTM selector = do - bs <- forM hs $ \h -> do +outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer) +outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr + where + waitgetbuf h = do let bv = bufferFor h (selected, rest) <- selector <$> takeTMVar bv + when (selected == OutputBuffer []) + retry putTMVar bv rest - return selected - if all (== OutputBuffer []) bs - then retry - else do - return (zip hs bs) - where - hs = [StdOut, StdErr] + return (h, selected) waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer) waitAnyBuffer b = (b, OutputBuffer []) diff --git a/System/Console/Regions.hs b/System/Console/Regions.hs --- a/System/Console/Regions.hs +++ b/System/Console/Regions.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BangPatterns, TupleSections, TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE CPP #-} -- | -- Copyright: 2015 Joey Hess @@ -88,21 +88,20 @@ -- For example, a region that displays the screen size, -- and automatically refreshes it: -- - -- > import System.Console.Terminal.Size -- > import qualified Data.Text as T -- -- > r <- openConsoleRegion Linear s -- > setConsoleRegion r $ do - -- > sz <- readTVar consoleSize + -- > w <- readTVar consoleWidth + -- > h <- readTVar consoleHeight -- > return $ T.pack $ unwords -- > [ "size:" - -- > , show (width sz) + -- > , show w -- > , "x" - -- > , show (height sz) + -- > , show h -- > ] -- > RegionContent(..), - consoleSize, consoleWidth, consoleHeight, regionList, @@ -124,10 +123,12 @@ import qualified System.Console.Terminal.Size as Console import System.IO import System.IO.Unsafe (unsafePerformIO) -import System.Posix.Signals -import System.Posix.Signals.Exts import Text.Read import Data.List +#ifndef mingw32_HOST_OS +import System.Posix.Signals +import System.Posix.Signals.Exts +#endif import System.Console.Concurrent import Utility.Monad @@ -175,8 +176,9 @@ regionList :: TMVar [ConsoleRegion] regionList = unsafePerformIO newEmptyTMVarIO --- | On unix systems, this TVar is automatically updated when the --- terminal is resized. +-- | On Unix systems, this TVar is automatically updated when the +-- terminal is resized. On Windows, it is only initialized on program start +-- with the current terminal size. {-# NOINLINE consoleSize #-} consoleSize :: TVar (Console.Window Int) consoleSize = unsafePerformIO $ newTVarIO $ @@ -184,13 +186,24 @@ type Width = Int --- | Get the width from the `consoleSize` +-- | Gets the width of the console. +-- +-- On Unix, this is automatically updated when the terminal is resized. +-- On Windows, it is only initialized on program start. consoleWidth :: STM Int -consoleWidth = Console.width <$> readTVar consoleSize +consoleWidth = munge . Console.width <$> readTVar consoleSize + where +#ifndef mingw32_HOST_OS + munge = id +#else + -- On Windows, writing to the right-most column caused some + -- problimatic wrap, so avoid it. + munge = pred +#endif -- | Get the height from the `consoleSize` consoleHeight :: STM Int -consoleHeight = Console.width <$> readTVar consoleSize +consoleHeight = Console.height <$> readTVar consoleSize -- | The RegionList TMVar is left empty when `displayConsoleRegions` -- is not running. @@ -304,8 +317,8 @@ return h -- | Makes a new region, but does not add it to the display. -newConsoleRegion :: ToRegionContent v => RegionLayout -> v -> STM ConsoleRegion -newConsoleRegion ly v = do +newConsoleRegion :: (LiftRegion m) => ToRegionContent v => RegionLayout -> v -> m ConsoleRegion +newConsoleRegion ly v = liftRegion $ do rc <- newTVar mempty rl <- newTVar mempty rs <- newTVar mempty @@ -439,7 +452,7 @@ installResizeHandler (Just getwidth) data DisplayChange - = BufferChange [(StdHandle, OutputBuffer)] + = BufferChange (StdHandle, OutputBuffer) | RegionChange RegionSnapshot | TerminalResize Width | EndSignal () @@ -455,7 +468,7 @@ let waitwidthchange = do w <- consoleWidth if w == origwidth then retry else return w - change <- atomically $ + let waitanychange = (RegionChange <$> regionWaiter origsnapshot origwidth) `orElse` (RegionChange <$> regionListWaiter origsnapshot) @@ -465,21 +478,31 @@ (TerminalResize <$> waitwidthchange) `orElse` (EndSignal <$> waitTSem endsignal) + (change, height) <- atomically $ (,) + <$> waitanychange + <*> consoleHeight + let onscreen = take (height - 1) . concat case change of RegionChange snapshot@(_, _, newlines) -> do when isterm $ do - changedLines (concat origlines) (concat newlines) + changedLines (onscreen origlines) (onscreen newlines) go snapshot origwidth - BufferChange buffers -> do - inAreaAbove isterm (length $ concat origlines) (concat origlines) $ - mapM_ (uncurry emitOutputBuffer) buffers + BufferChange (h, buf) -> do + -- Note that even when every available line + -- is dedicated to visible regions, the + -- buffer is still displayed. It would be + -- more efficient to not display it, but + -- this makes it available in scroll back. + let origlines' = onscreen origlines + inAreaAbove isterm (length origlines') origlines' $ + emitOutputBuffer h buf go origsnapshot origwidth TerminalResize newwidth -> do (newregions, lls) <- unzip <$> atomically (mapM (resizeRegion newwidth) orighandles) let newlines = map reverse lls when isterm $ do - resizeRecovery newlines + resizeRecovery (onscreen newlines) go (orighandles, newregions, newlines) newwidth EndSignal () -> return () @@ -563,8 +586,16 @@ | otherwise = do forM_ l' $ \((newt, offset), oldt) -> do cursorUpLine offset - T.hPutStr stdout $ +#ifndef mingw32_HOST_OS + T.hPutStr stdout $ genLineUpdate $ calcLineUpdate oldt newt +#else + -- Windows does not support ansi characters + -- emitted in a string, so do a full line + -- redraw. + T.hPutStr stdout newt + clearFromCursorToLineEnd +#endif cursorDownLine (sum (map (snd . fst) l')) setCursorColumn 0 hFlush stdout @@ -576,10 +607,10 @@ -- The resize can change the position of the cursor, which would garble -- the display going forward. To fix, the cursor is moved to the top of -- the screen, which is cleared, and all regions are redrawn from there. -resizeRecovery :: [[Text]] -> IO () +resizeRecovery :: [Text] -> IO () resizeRecovery newlines = do setCursorPosition 0 0 - inAreaAbove True 0 (concat newlines) $ + inAreaAbove True 0 newlines $ return () -- Move cursor up before the lines, performs some output there, @@ -591,6 +622,9 @@ unless (numlines < 1) $ cursorUpLine $ numlines clearFromCursorToScreenEnd + -- Flush stdout now, because the outputter may write to stderr, so + -- the cursor needs to be moved first. + hFlush stdout outputter when isterm $ do setCursorColumn 0 -- just in case the output lacked a newline @@ -603,8 +637,12 @@ putChar '\n' installResizeHandler :: Maybe (IO ()) -> IO () +#ifndef mingw32_HOST_OS installResizeHandler h = void $ installHandler windowChange (maybe Default Catch h) Nothing +#else +installResizeHandler _ = return () +#endif calcRegionLines :: R -> Text -> Width -> STM [Text] calcRegionLines r content width = do diff --git a/System/Process/Concurrent.hs b/System/Process/Concurrent.hs --- a/System/Process/Concurrent.hs +++ b/System/Process/Concurrent.hs @@ -5,6 +5,8 @@ -- The functions exported by this module are intended to be drop-in -- replacements for those from System.Process, when converting a whole -- program to use System.Console.Concurrent. +-- +-- Not currently available on Windows. module System.Process.Concurrent where @@ -19,6 +21,8 @@ -- You should use the waitForProcess in this module on the resulting -- ProcessHandle. Using System.Process.waitForProcess instead can have -- mildly unexpected results. +-- +-- Not available on Windows. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p diff --git a/aptdemo.hs b/aptdemo.hs --- a/aptdemo.hs +++ b/aptdemo.hs @@ -12,10 +12,15 @@ , [dl "foo", dl "bar", dl "very large"] ] `concurrently` mapM_ message [1..20] + `concurrently` mapM_ errormessage [2,6..20] message n = do threadDelay 500000 outputConcurrent ("Updated blah blah #" ++ show n ++ "\n") + +errormessage n = do + threadDelay 2300000 + outputConcurrent ("Failed to frob " ++ show n ++ "\n") downline cs = withConsoleRegion Linear $ \r -> mapConcurrently (\a -> a r) (reverse cs) diff --git a/concurrent-output.cabal b/concurrent-output.cabal --- a/concurrent-output.cabal +++ b/concurrent-output.cabal @@ -1,5 +1,5 @@ Name: concurrent-output -Version: 1.5.0 +Version: 1.6.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess @@ -37,7 +37,6 @@ , async (>= 2.0 && < 2.1) , stm (>= 2.0 && < 2.5) , process (>= 1.2.0 && < 1.4.0) - , unix (>= 2.7.0 && < 2.8.0) , directory (>= 1.2.0 && < 1.3.0) , transformers (>= 0.3.0 && < 0.5.0) , exceptions (>= 0.8.0 && < 0.9.0) @@ -47,11 +46,14 @@ System.Console.Concurrent System.Console.Concurrent.Internal System.Console.Regions - System.Process.Concurrent Other-Modules: Utility.Monad Utility.Data Utility.Exception + + if (! os(Windows)) + Build-Depends: unix (>= 2.7.0 && < 2.8.0) + Exposed-Modules: System.Process.Concurrent source-repository head type: git diff --git a/stmdemo.hs b/stmdemo.hs --- a/stmdemo.hs +++ b/stmdemo.hs @@ -1,7 +1,6 @@ import Control.Concurrent.Async import Control.Concurrent import System.Console.Regions -import System.Console.Terminal.Size import qualified Data.Text as T import Control.Concurrent.STM import Control.Applicative @@ -21,13 +20,14 @@ infoRegion = do r <- openConsoleRegion Linear setConsoleRegion r $ do - sz <- readTVar consoleSize + w <- readTVar consoleWidth + h <- readTVar consoleHeight regions <- readTMVar regionList return $ T.pack $ unwords [ "size:" - , show (width sz) + , show w , "x" - , show (height sz) + , show h , "regions: " , show (length regions) ]