Hello community, here is the log from the commit of package ghc-concurrent-output for openSUSE:Factory checked in at 2017-08-31 20:50:21 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-concurrent-output (Old) and /work/SRC/openSUSE:Factory/.ghc-concurrent-output.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-concurrent-output" Thu Aug 31 20:50:21 2017 rev:6 rq:513223 version:1.9.2 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-concurrent-output/ghc-concurrent-output.changes 2017-03-20 17:06:31.447613784 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-concurrent-output.new/ghc-concurrent-output.changes 2017-08-31 20:50:22.478729705 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:12 UTC 2017 - psim...@suse.com + +- Update to version 1.9.2. + +------------------------------------------------------------------- Old: ---- concurrent-output-1.7.9.tar.gz New: ---- concurrent-output-1.9.2.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-concurrent-output.spec ++++++ --- /var/tmp/diff_new_pack.uEhzAY/_old 2017-08-31 20:50:23.682560723 +0200 +++ /var/tmp/diff_new_pack.uEhzAY/_new 2017-08-31 20:50:23.694559038 +0200 @@ -18,7 +18,7 @@ %global pkg_name concurrent-output Name: ghc-%{pkg_name} -Version: 1.7.9 +Version: 1.9.2 Release: 0 Summary: Ungarble output from several threads or commands License: BSD-2-Clause ++++++ concurrent-output-1.7.9.tar.gz -> concurrent-output-1.9.2.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/concurrent-output-1.7.9/CHANGELOG new/concurrent-output-1.9.2/CHANGELOG --- old/concurrent-output-1.7.9/CHANGELOG 2017-02-12 23:15:31.000000000 +0100 +++ new/concurrent-output-1.9.2/CHANGELOG 2017-05-19 17:37:54.000000000 +0200 @@ -1,3 +1,35 @@ +concurrent-output (1.9.2) unstable; urgency=medium + + * Allow process-1.6.0.0. + + -- Joey Hess <i...@joeyh.name> Fri, 19 May 2017 11:36:35 -0400 + +concurrent-output (1.9.1) unstable; urgency=medium + + * Documentation fix: createProcessConcurrent has been available on + Windows since 1.7.5 but the docs said not. + * When all regions are closed, flush stdout so that the display gets + updated, which didn't happen before. + + -- Joey Hess <i...@joeyh.name> Tue, 16 May 2017 16:49:43 -0400 + +concurrent-output (1.9.0) unstable; urgency=medium + + * Replaced displayUpdateNotifier with a simpler and safer + waitDisplayChange interface. + + -- Joey Hess <i...@joeyh.name> Fri, 12 May 2017 17:17:09 -0400 + +concurrent-output (1.8.0) unstable; urgency=medium + + * Added displayUpdateNotifier, which can be used to wait for + changes to console regions to be displayed. + (stmdemo has an example of using that to temporarily shut down the + region based display to run a bash prompt, and restore the region + display later.) + + -- Joey Hess <i...@joeyh.name> Fri, 12 May 2017 16:27:41 -0400 + concurrent-output (1.7.9) unstable; urgency=medium * Allow lazy text to be used as an Outputable value, and as diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/concurrent-output-1.7.9/LICENSE new/concurrent-output-1.9.2/LICENSE --- old/concurrent-output-1.7.9/LICENSE 2017-02-12 23:15:31.000000000 +0100 +++ new/concurrent-output-1.9.2/LICENSE 2017-05-19 17:37:54.000000000 +0200 @@ -1,4 +1,4 @@ -Copyright © 2015 Joey Hess <i...@joeyh.name> +Copyright © 2015-2017 Joey Hess <i...@joeyh.name> Copyright © 2009 Joachim Breitner Redistribution and use in source and binary forms, with or without diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/concurrent-output-1.7.9/System/Console/Concurrent/Internal.hs new/concurrent-output-1.9.2/System/Console/Concurrent/Internal.hs --- old/concurrent-output-1.7.9/System/Console/Concurrent/Internal.hs 2017-02-12 23:15:31.000000000 +0100 +++ new/concurrent-output-1.9.2/System/Console/Concurrent/Internal.hs 2017-05-19 17:37:54.000000000 +0200 @@ -147,15 +147,20 @@ -- | Displays a value to stdout. -- --- No newline is appended to the value, so if you want a newline, be sure --- to include it yourself. --- -- Uses locking to ensure that the whole output occurs atomically -- even when other threads are concurrently generating output. -- +-- No newline is appended to the value, so if you want a newline, be sure +-- to include it yourself. +-- -- When something else is writing to the console at the same time, this does -- not block. It buffers the value, so it will be displayed once the other -- writer is done. +-- +-- When outputConcurrent is used within a call to +-- `System.Console.Regions.displayConsoleRegions`, the output is displayed +-- above the currently open console regions. Only lines ending in a newline +-- are displayed in this case (it uses `waitCompleteLines`). outputConcurrent :: Outputable v => v -> IO () outputConcurrent = outputConcurrent' StdOut @@ -261,8 +266,6 @@ -- 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. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) createProcessConcurrent p | willOutput (P.std_out p) || willOutput (P.std_err p) = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/concurrent-output-1.7.9/System/Console/Regions.hs new/concurrent-output-1.9.2/System/Console/Regions.hs --- old/concurrent-output-1.7.9/System/Console/Regions.hs 2017-02-12 23:15:31.000000000 +0100 +++ new/concurrent-output-1.9.2/System/Console/Regions.hs 2017-05-19 17:37:54.000000000 +0200 @@ -9,7 +9,9 @@ -- License: BSD-2-clause -- -- Console regions are displayed near the bottom of the console, and can be --- updated concurrently by threads. Any other output displayed using +-- updated concurrently by threads. +-- +-- Any other output lines displayed using -- `outputConcurrent` and `createProcessConcurrent` -- will scroll up above the open console regions. -- @@ -108,6 +110,7 @@ consoleWidth, consoleHeight, regionList, + waitDisplayChange, ) where import Data.Monoid @@ -207,8 +210,7 @@ consoleHeight :: STM Int consoleHeight = Console.height <$> readTVar consoleSize --- | The RegionList TMVar is left empty when `displayConsoleRegions` --- is not running. +-- | Check if `displayConsoleRegions` is running. regionDisplayEnabled :: IO Bool regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList @@ -431,47 +433,93 @@ trackConsoleWidth :: IO () trackConsoleWidth = do - let getwidth = maybe noop (atomically . writeTVar consoleSize) + let getsz = maybe noop (atomically . writeTVar consoleSize) =<< Console.size - getwidth - installResizeHandler (Just getwidth) + getsz + installResizeHandler (Just getsz) data DisplayChange - = BufferChange (StdHandle, OutputBuffer) + = BufferChange BufferSnapshot | RegionChange RegionSnapshot + | RegionListChange RegionSnapshot | TerminalResize Width - | EndSignal () + | Shutdown + | DisplayChangeBarrier Barrier +type BufferSnapshot = (StdHandle, OutputBuffer) type RegionSnapshot = ([ConsoleRegion], [R], [[Text]]) +type Barrier = Integer + +-- | This is a broadcast TChan, which gets a DisplayChange written to it +-- after the display has been updated. It can be used to wait for something +-- to be displayed. +{-# NOINLINE displayUpdateNotifier #-} +displayUpdateNotifier :: TChan DisplayChange +displayUpdateNotifier = unsafePerformIO $ newBroadcastTChanIO + +{-# NOINLINE displayChangeBarrier #-} +displayChangeBarrier :: TVar Barrier +displayChangeBarrier = unsafePerformIO $ newTVarIO 0 + +-- | Runs a STM action, and waits for the display to be fully updated +-- before returning. +waitDisplayChange :: STM a -> IO a +waitDisplayChange a = do + r <- atomically a + c <- atomically $ dupTChan displayUpdateNotifier + b <- atomically $ do + !b <- succ <$> readTVar displayChangeBarrier + writeTVar displayChangeBarrier b + return b + atomically $ waitchange c b + return r + where + waitchange c b = do + change <- readTChan c + case change of + DisplayChangeBarrier b' | b' == b -> return () + _ -> waitchange c b displayThread :: Bool -> TSem -> IO () displayThread isterm endsignal = do origwidth <- atomically consoleWidth - go ([], [], []) origwidth + origbarrier <- atomically (readTVar displayChangeBarrier) + go ([], [], []) origwidth origbarrier where - go origsnapshot@(orighandles, origregions, origlines) origwidth = do + go origsnapshot@(orighandles, origregions, origlines) origwidth origbarrier = do let waitwidthchange = do w <- consoleWidth if w == origwidth then retry else return w + let waitbarrierchange = do + b <- readTVar displayChangeBarrier + if b /= origbarrier + then return b + else retry let waitanychange = (RegionChange <$> regionWaiter origsnapshot origwidth) `orElse` - (RegionChange <$> regionListWaiter origsnapshot) + (RegionListChange <$> regionListWaiter origsnapshot) `orElse` (BufferChange <$> outputBufferWaiterSTM waitCompleteLines) `orElse` (TerminalResize <$> waitwidthchange) `orElse` - (EndSignal <$> waitTSem endsignal) + (waitTSem endsignal >> pure Shutdown) + `orElse` + -- Must come last, so the changes above are + -- processed before barriers. + (DisplayChangeBarrier <$> waitbarrierchange) (change, height) <- atomically $ (,) <$> waitanychange <*> consoleHeight let onscreen = take (height - 1) . concat - case change of - RegionChange snapshot@(_, _, newlines) -> do - when isterm $ do - changedLines (onscreen origlines) (onscreen newlines) - go snapshot origwidth + let update snapshot@(_, _, newlines) = do + when isterm $ + changedLines (onscreen origlines) (onscreen newlines) + return $ go snapshot origwidth origbarrier + next <- case change of + RegionChange snapshot -> update snapshot + RegionListChange snapshot -> update snapshot BufferChange (h, buf) -> do -- Note that even when every available line -- is dedicated to visible regions, the @@ -481,13 +529,19 @@ let origlines' = onscreen origlines inAreaAbove isterm (length origlines') origlines' $ emitOutputBuffer h buf - go origsnapshot origwidth + return $ go origsnapshot origwidth origbarrier TerminalResize newwidth -> do newlines <- atomically (mapM (resizeRegion newwidth) orighandles) when isterm $ do resizeRecovery (onscreen newlines) - go (orighandles, origregions, newlines) newwidth - EndSignal () -> return () + return $ go (orighandles, origregions, newlines) newwidth origbarrier + Shutdown -> + return $ return () + DisplayChangeBarrier b -> + return $ go origsnapshot origwidth b + hFlush stdout + atomically $ writeTChan displayUpdateNotifier change + next readRegions :: [ConsoleRegion] -> STM [R] readRegions = mapM (\(ConsoleRegion h) -> readTVar h) @@ -576,7 +630,6 @@ #endif cursorDown (sum (map (snd . fst) l')) setCursorColumn 0 - hFlush stdout where l' = changeOffsets l 1 [] @@ -608,7 +661,6 @@ when isterm $ do setCursorColumn 0 -- just in case the output lacked a newline displayLines (reverse ls) - hFlush stdout displayLines :: [Text] -> IO () displayLines = mapM_ $ \l -> do diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/concurrent-output-1.7.9/concurrent-output.cabal new/concurrent-output-1.9.2/concurrent-output.cabal --- old/concurrent-output-1.7.9/concurrent-output.cabal 2017-02-12 23:15:31.000000000 +0100 +++ new/concurrent-output-1.9.2/concurrent-output.cabal 2017-05-19 17:37:54.000000000 +0200 @@ -1,11 +1,11 @@ Name: concurrent-output -Version: 1.7.9 +Version: 1.9.2 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <i...@joeyh.name> Author: Joey Hess, Joachim Breitner Stability: Stable -Copyright: 2015 Joey Hess, 2009 Joachim Breitner +Copyright: 2015-2017 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple Category: User Interfaces @@ -34,7 +34,7 @@ , text (>= 0.11.0 && < 1.3.0) , async (>= 2.0 && < 2.2) , stm (>= 2.0 && < 2.5) - , process (>= 1.1.0 && < 1.5.0) + , process (>= 1.1.0 && < 1.7.0) , directory (>= 1.2.0 && < 1.4.0) , transformers (>= 0.3.0 && < 0.6.0) , exceptions (>= 0.6.0 && < 0.9.0) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/concurrent-output-1.7.9/stmdemo.hs new/concurrent-output-1.9.2/stmdemo.hs --- old/concurrent-output-1.7.9/stmdemo.hs 2017-02-12 23:15:31.000000000 +0100 +++ new/concurrent-output-1.9.2/stmdemo.hs 2017-05-19 17:37:54.000000000 +0200 @@ -7,15 +7,25 @@ import Data.Time.Clock import Control.Monad import Data.Monoid +import System.Process main :: IO () main = void $ displayConsoleRegions $ do + void titleRegion ir <- infoRegion cr <- clockRegion rr <- rulerRegion growingDots + runBash + growingDots mapM_ closeConsoleRegion [ir, cr] +titleRegion :: IO ConsoleRegion +titleRegion = do + r <- openConsoleRegion Linear + setConsoleRegion r "STM demo!" + return r + infoRegion :: IO ConsoleRegion infoRegion = do r <- openConsoleRegion Linear @@ -48,24 +58,34 @@ rightAlign r return r +rulerRegion :: IO ConsoleRegion +rulerRegion = do + r <- openConsoleRegion Linear + setConsoleRegion r $ do + width <- consoleWidth + return $ T.pack $ take width nums + return r + where + nums = cycle $ concatMap show [0..9] + rightAlign :: ConsoleRegion -> STM () rightAlign r = tuneDisplay r $ \t -> do w <- consoleWidth return (T.replicate (w - T.length t) (T.singleton ' ') <> t) +growingDots :: IO () growingDots = withConsoleRegion Linear $ \r -> do atomically $ rightAlign r width <- atomically consoleWidth - replicateM width $ do + void $ replicateM width $ do appendConsoleRegion r "." threadDelay (100000) -rulerRegion :: IO ConsoleRegion -rulerRegion = do - r <- openConsoleRegion Linear - setConsoleRegion r $ do - width <- consoleWidth - return $ T.pack $ take width nums - return r - where - nums = cycle $ concatMap show [0..9] +runBash :: IO () +runBash = do + -- Temporarily clear whatever console regions are open. + rs <- waitDisplayChange $ swapTMVar regionList [] + putStrLn "We interrupt this demo to run a shell prompt. exit to continue!" + callCommand "bash" + -- Restore the console regions. + void $ atomically $ swapTMVar regionList rs