diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +concurrent-output (1.5.0) unstable; urgency=medium + + * Added errorConcurrent. + * Added getRegionContent. + + -- Joey Hess Wed, 04 Nov 2015 17:20:44 -0400 + concurrent-output (1.4.0) unstable; urgency=medium * Renamed many of the functions and types. diff --git a/System/Console/Concurrent.hs b/System/Console/Concurrent.hs --- a/System/Console/Concurrent.hs +++ b/System/Console/Concurrent.hs @@ -19,6 +19,7 @@ withConcurrentOutput, Outputable(..), outputConcurrent, + errorConcurrent, ConcurrentProcessHandle, createProcessConcurrent, waitForProcessConcurrent, 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 @@ -149,19 +149,29 @@ -- not block. It buffers the value, so it will be displayed once the other -- writer is done. outputConcurrent :: Outputable v => v -> IO () -outputConcurrent v = bracket setup cleanup go +outputConcurrent = outputConcurrent' StdOut + +-- | Like `outputConcurrent`, but displays to stderr. +-- +-- (Does not throw an exception.) +errorConcurrent :: Outputable v => v -> IO () +errorConcurrent = outputConcurrent' StdErr + +outputConcurrent' :: Outputable v => StdHandle -> v -> IO () +outputConcurrent' stdh v = bracket setup cleanup go where setup = tryTakeOutputLock cleanup False = return () cleanup True = dropOutputLock go True = do - T.hPutStr stdout (toOutput v) - hFlush stdout + T.hPutStr h (toOutput v) + hFlush h go False = do - let bv = outputBuffer globalOutputHandle oldbuf <- atomically $ takeTMVar bv newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf atomically $ putTMVar bv newbuf + h = toHandle stdh + bv = bufferFor stdh newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle diff --git a/System/Console/Regions.hs b/System/Console/Regions.hs --- a/System/Console/Regions.hs +++ b/System/Console/Regions.hs @@ -77,6 +77,7 @@ setConsoleRegion, appendConsoleRegion, finishConsoleRegion, + getConsoleRegion, tuneDisplay, -- * STM region contents -- @@ -334,13 +335,19 @@ Linear -> return () InLine parent -> removeChild h parent --- | Closes the console region and displays the passed value in the --- scrolling area above the active console regions. +-- | Closes the console region, and displays the passed value in the +-- scrolling area above the active console regions. When Nothing is passed, +-- displays the current value of the console region. finishConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m () finishConsoleRegion h v = liftRegion $ do closeConsoleRegion h bufferOutputSTM StdOut (toOutput v <> fromString "\n") +-- | Gets the current content of a console region. +getConsoleRegion :: LiftRegion m => ConsoleRegion -> m Text +getConsoleRegion (ConsoleRegion tv) = liftRegion $ + readRegionContent . regionContent =<< readTVar tv + -- | Changes how a console region displays. -- -- Each time the region's value changes, the STM action is provided @@ -472,15 +479,7 @@ atomically (mapM (resizeRegion newwidth) orighandles) let newlines = map reverse lls when isterm $ do - -- A resize can leave the cursor - -- in a fairly undefined location, - -- if it occurred while a screen - -- draw was in progress. Move the - -- cursor to top of screen, clear - -- entire screen, and redisplay. - setCursorPosition 0 0 - inAreaAbove isterm 0 (concat newlines) $ - return () + resizeRecovery newlines go (orighandles, newregions, newlines) newwidth EndSignal () -> return () @@ -571,6 +570,17 @@ hFlush stdout where l' = changeOffsets l 1 [] + +-- Recover from a resize by redrawing all region lines. +-- +-- 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 newlines = do + setCursorPosition 0 0 + inAreaAbove True 0 (concat newlines) $ + return () -- Move cursor up before the lines, performs some output there, -- which will scroll down and overwrite the lines, so 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.4.0 +Version: 1.5.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess diff --git a/stmdemo.hs b/stmdemo.hs --- a/stmdemo.hs +++ b/stmdemo.hs @@ -10,13 +10,14 @@ import Data.Monoid main :: IO () -main = void $ displayConsoleRegions $ mapConcurrently id - [ infoRegion - , clockRegion - , growingDots - ] +main = void $ displayConsoleRegions $ do + ir <- infoRegion + cr <- clockRegion + rr <- rulerRegion + growingDots + mapM_ closeConsoleRegion [ir, cr] -infoRegion :: IO () +infoRegion :: IO ConsoleRegion infoRegion = do r <- openConsoleRegion Linear setConsoleRegion r $ do @@ -30,20 +31,22 @@ , "regions: " , show (length regions) ] + return r timeDisplay :: TVar UTCTime -> STM T.Text timeDisplay tv = T.pack . show <$> readTVar tv -clockRegion :: IO () +clockRegion :: IO ConsoleRegion clockRegion = do tv <- atomically . newTVar =<< getCurrentTime - void $ atomically $ do + async $ forever $ do + threadDelay 1000000 -- 1 sec + atomically . (writeTVar tv) =<< getCurrentTime + atomically $ do r <- openConsoleRegion Linear setConsoleRegion r (timeDisplay tv) rightAlign r - forever $ do - threadDelay 1000000 -- 1 sec - atomically . (writeTVar tv) =<< getCurrentTime + return r rightAlign :: ConsoleRegion -> STM () rightAlign r = tuneDisplay r $ \t -> do @@ -52,6 +55,17 @@ growingDots = withConsoleRegion Linear $ \r -> do atomically $ rightAlign r - forever $ do - appendConsoleRegion r "." + width <- atomically consoleWidth + 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]