diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,14 @@ +concurrent-output (1.3.0) unstable; urgency=medium + + * The contents of a Region can now be set to a STM Text + transaction. Their display will be automatically updated whenever the + transaction's value changes. + * Removed updateRegionListSTM, and export regionList instead, which is + more general-purpose. + * Other improvements to STM interface. + + -- Joey Hess Tue, 03 Nov 2015 15:50:47 -0400 + concurrent-output (1.2.0) unstable; urgency=medium * Avoid crash when not all of a program's output is consumed, as diff --git a/System/Console/Regions.hs b/System/Console/Regions.hs --- a/System/Console/Regions.hs +++ b/System/Console/Regions.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, TupleSections #-} +{-# LANGUAGE BangPatterns, TupleSections, TypeSynonymInstances, FlexibleInstances #-} -- | -- Copyright: 2015 Joey Hess @@ -68,7 +68,8 @@ withConsoleRegion, openConsoleRegion, closeConsoleRegion, - -- * Output + -- * Region display + Displayable(..), setConsoleRegion, appendConsoleRegion, finishConsoleRegion, @@ -78,10 +79,38 @@ -- once the transaction completes the console will be updated -- a single time to reflect all the changes made. openConsoleRegionSTM, + newConsoleRegionSTM, closeConsoleRegionSTM, setConsoleRegionSTM, appendConsoleRegionSTM, - updateRegionListSTM, + -- * STM regions + -- + -- | The `Displayable` instance for STM text can be used to + -- make regions that automatically update whenever there's + -- a change to any of the STM values that they use. + -- + -- 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 + -- > return $ T.pack $ unwords + -- > [ "size:" + -- > , show (width sz) + -- > , "x" + -- > , show (height sz) + -- > ] + -- > + RegionContent(..), + readRegionContent, + consoleSize, + Width, + consoleWidth, + regionList, ) where import Data.Monoid @@ -120,8 +149,8 @@ -- > bbbbbbbbbbbbbbb -- Linear -- > bbb............ (expanded to multiple lines) -- > ccccccccc...... -- Linear --- > ddd eee fffffff -- [InLine] --- > ffff ggggg..... (expanded to multiple lines) +-- > ddddeeeefffffff -- [InLine] +-- > fffffggggg..... (expanded to multiple lines) -- > data RegionLayout = Linear | InLine ConsoleRegionHandle deriving (Eq) @@ -130,43 +159,63 @@ deriving (Eq) data Region = Region - { regionContent :: T.Text - , regionLines :: [T.Text] -- cache + { regionContent :: RegionContent + , regionLines :: TVar [T.Text] -- ^ cache of regionContent , regionLayout :: RegionLayout , regionChildren :: Maybe [ConsoleRegionHandle] } -instance Eq Region where - a == b = regionContent a == regionContent b - && regionLayout a == regionLayout b - -type RegionList = TMVar [ConsoleRegionHandle] +data RegionContent + = RegionContent (TVar T.Text) + | RegionContentSTM (STM T.Text) --- | A shared global list of regions. +-- | All the regions that are currently displayed on the screen. +-- +-- The list is ordered from the bottom of the screen up. Reordering +-- it will change the order in which regions are displayed. +-- It's also fine to remove, duplicate, or add new regions to the list. {-# NOINLINE regionList #-} -regionList :: RegionList +regionList :: TMVar [ConsoleRegionHandle] regionList = unsafePerformIO newEmptyTMVarIO -type Width = Int +-- | On unix systems, this TVar is automatically updated when the +-- terminal is resized. +{-# NOINLINE consoleSize #-} +consoleSize :: TVar (Console.Window Int) +consoleSize = unsafePerformIO $ newTVarIO $ + Console.Window { Console.width = 80, Console.height = 25} --- | A shared global console width. -{-# NOINLINE consoleWidth #-} -consoleWidth :: TVar Width -consoleWidth = unsafePerformIO (newTVarIO 80) +type Width = Int --- | Updates the list of regions. The list is ordered from the bottom of --- the screen up. Reordering it will change the order in which regions are --- displayed. It's also fine to remove, duplicate, or add new regions to the --- list. -updateRegionListSTM :: ([ConsoleRegionHandle] -> [ConsoleRegionHandle]) -> STM () -updateRegionListSTM f = - maybe noop (putTMVar regionList . f) =<< tryTakeTMVar regionList +-- Get the width from the `consoleSize` +consoleWidth :: STM Width +consoleWidth = Console.width <$> readTVar consoleSize -- | The RegionList TMVar is left empty when `displayConsoleRegions` -- is not running. regionDisplayEnabled :: IO Bool regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList +-- | Values that can be displayed in a region. +class Displayable v where + toRegionContent :: v -> STM RegionContent + +instance Displayable String where + toRegionContent = fromOutput + +instance Displayable T.Text where + toRegionContent = fromOutput + +fromOutput :: Outputable v => v -> STM RegionContent +fromOutput v = RegionContent <$> newTVar (toOutput v) + +-- | Makes a STM action be run to get the content of a region. +-- +-- Any change to the values that action reads will result in an immediate +-- refresh of the display. +instance Displayable (STM T.Text) where + toRegionContent = pure . RegionContentSTM + -- | Sets the value to display within a console region. -- -- It's fine for the value to be longer than the terminal is wide, @@ -178,14 +227,16 @@ -- -- Other ANSI escape sequences, especially those doing cursor -- movement, will mess up the layouts of regions. Caveat emptor. -setConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO () +setConsoleRegion :: Displayable v => ConsoleRegionHandle -> v -> IO () setConsoleRegion h = atomically . setConsoleRegionSTM h -setConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () +-- | STM version of `setConsoleRegion` +setConsoleRegionSTM :: Displayable v => ConsoleRegionHandle -> v -> STM () setConsoleRegionSTM (ConsoleRegionHandle tv) v = do r <- readTVar tv - width <- readTVar consoleWidth - writeTVar tv (modifyRegion r width (const (toOutput v))) + width <- consoleWidth + r' <- modifyRegion r width $ const $ toRegionContent v + writeTVar tv r' case regionLayout r of Linear -> return () InLine p -> refreshParent p @@ -195,26 +246,46 @@ appendConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO () appendConsoleRegion h = atomically . appendConsoleRegionSTM h +-- | STM version of `appendConsoleRegion` appendConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () appendConsoleRegionSTM (ConsoleRegionHandle tv) v = do r <- readTVar tv - width <- readTVar consoleWidth - writeTVar tv (modifyRegion r width (<> toOutput v)) + width <- consoleWidth + r' <- modifyRegion r width $ \rc -> case rc of + RegionContent cv -> do + modifyTVar' cv (<> toOutput v) + return rc + RegionContentSTM a -> return $ RegionContentSTM $ do + t <- a + return (t <> toOutput v) + writeTVar tv r' case regionLayout r of Linear -> return () InLine p -> refreshParent p -modifyRegion :: Region -> Width -> (T.Text -> T.Text) -> Region -modifyRegion r width f = r { regionContent = c, regionLines = calcRegionLines c width } - where - !c = f (regionContent r) +modifyRegion :: Region -> Width -> (RegionContent -> STM RegionContent) -> STM Region +modifyRegion r width f = do + rc <- f (regionContent r) + t <- readRegionContent' rc + writeTVar (regionLines r) (calcRegionLines t width) + return $ r { regionContent = rc } -resizeRegion :: Width -> ConsoleRegionHandle -> STM Region +-- | Reads the content of a region. +readRegionContent :: ConsoleRegionHandle -> STM T.Text +readRegionContent (ConsoleRegionHandle tv) = + readRegionContent' . regionContent =<< readTVar tv + +readRegionContent' :: RegionContent -> STM T.Text +readRegionContent' (RegionContent t) = readTVar t +readRegionContent' (RegionContentSTM a) = a + +resizeRegion :: Width -> ConsoleRegionHandle -> STM (Region, [T.Text]) resizeRegion width (ConsoleRegionHandle tv) = do r <- readTVar tv - let !r' = modifyRegion r width id - writeTVar tv r' - return r' + t <- readRegionContent' (regionContent r) + let ls = calcRegionLines t width + writeTVar (regionLines r) ls + return (r, ls) -- | Runs the action with a new console region, closing the region when -- the action finishes or on exception. @@ -223,23 +294,16 @@ -- | Opens a new console region for output. openConsoleRegion :: RegionLayout -> IO ConsoleRegionHandle -openConsoleRegion = atomically . openConsoleRegionSTM +openConsoleRegion ly = atomically $ openConsoleRegionSTM ly T.empty -- | STM version of `openConsoleRegion`. Allows atomically opening multiple --- regions at the same time, which guarantees they are on adjacent lines. +-- regions at the same time, which guarantees they are adjacent. -- -- > [r1, r2, r3] <- atomically $ --- > replicateM 3 (openConsoleRegionSTM Linear) -openConsoleRegionSTM :: RegionLayout -> STM ConsoleRegionHandle -openConsoleRegionSTM ly = do - width <- readTVar consoleWidth - let r = Region - { regionContent = mempty - , regionLines = calcRegionLines mempty width - , regionLayout = ly - , regionChildren = Nothing - } - h <- ConsoleRegionHandle <$> newTVar r +-- > replicateM 3 (openConsoleRegionSTM Linear T.empty) +openConsoleRegionSTM :: Displayable v => RegionLayout -> v -> STM ConsoleRegionHandle +openConsoleRegionSTM ly v = do + h <- newConsoleRegionSTM ly T.empty case ly of Linear -> do v <- tryTakeTMVar regionList @@ -249,7 +313,23 @@ -- it's not put on any list, and won't display Nothing -> return () InLine parent -> addChild h parent + setConsoleRegionSTM h v + return h +-- | Makes a new region, but does not add it to the display. +newConsoleRegionSTM :: Displayable v => RegionLayout -> v -> STM ConsoleRegionHandle +newConsoleRegionSTM ly v = do + width <- consoleWidth + rc <- newTVar mempty + ls <- newTVar $ calcRegionLines mempty width + let r = Region + { regionContent = RegionContent rc + , regionLines = ls + , regionLayout = ly + , regionChildren = Nothing + } + h <- ConsoleRegionHandle <$> newTVar r + setConsoleRegionSTM h v return h -- | Closes a console region. Once closed, the region is removed from the @@ -296,19 +376,18 @@ refreshParent :: ConsoleRegionHandle -> STM () refreshParent (ConsoleRegionHandle pv) = do p <- readTVar pv - width <- readTVar consoleWidth + width <- consoleWidth case regionChildren p of Nothing -> return () Just l -> do - cs <- forM l $ \child@(ConsoleRegionHandle cv) -> do + cs <- forM l $ \child -> do refreshParent child - regionContent <$> readTVar cv + readRegionContent child let !c = mconcat cs - let p' = p - { regionContent = c - , regionLines = calcRegionLines c width - } + rc <- newTVar c + let p' = p { regionContent = RegionContent rc } writeTVar pv p' + writeTVar (regionLines p) (calcRegionLines c width) -- | Handles all display for the other functions in this module. -- @@ -344,13 +423,8 @@ trackConsoleWidth :: IO () trackConsoleWidth = do - let getwidth = do - v <- Console.size - case v of - Nothing -> return () - Just (Console.Window _height width) -> - atomically $ void $ - swapTVar consoleWidth width + let getwidth = maybe noop (atomically . writeTVar consoleSize) + =<< Console.size getwidth installResizeHandler (Just getwidth) @@ -360,19 +434,19 @@ | TerminalResize Width | EndSignal () -type RegionSnapshot = ([ConsoleRegionHandle], [Region]) +type RegionSnapshot = ([ConsoleRegionHandle], [Region], [[T.Text]]) displayThread :: Bool -> TSem -> IO () displayThread isterm endsignal = do - origwidth <- atomically $ readTVar consoleWidth - go ([], []) origwidth + origwidth <- atomically consoleWidth + go ([], [], []) origwidth where - go origsnapshot@(orighandles, origregions) origwidth = do + go origsnapshot@(orighandles, _origregions, origlines) origwidth = do let waitwidthchange = do - w <- readTVar consoleWidth + w <- consoleWidth if w == origwidth then retry else return w change <- atomically $ - (RegionChange <$> regionWaiter origsnapshot) + (RegionChange <$> regionWaiter origsnapshot origwidth) `orElse` (RegionChange <$> regionListWaiter origsnapshot) `orElse` @@ -382,19 +456,18 @@ `orElse` (EndSignal <$> waitTSem endsignal) case change of - RegionChange snapshot@(_, newregions) -> do - when isterm $ - changedLines - (getlines origregions) - (getlines newregions) + RegionChange snapshot@(_, _, newlines) -> do + when isterm $ do + changedLines (concat origlines) (concat newlines) go snapshot origwidth BufferChange buffers -> do - inAreaAbove isterm (length $ getlines origregions) (getlines origregions) $ + inAreaAbove isterm (length $ concat origlines) (concat origlines) $ mapM_ (uncurry emitOutputBuffer) buffers go origsnapshot origwidth TerminalResize newwidth -> do - newregions <- atomically $ - mapM (resizeRegion newwidth) orighandles + (newregions, lls) <- unzip <$> + atomically (mapM (resizeRegion newwidth) orighandles) + let newlines = map reverse lls when isterm $ do -- A resize can leave the cursor -- in a fairly undefined location, @@ -403,32 +476,41 @@ -- cursor to top of screen, clear -- entire screen, and redisplay. setCursorPosition 0 0 - inAreaAbove isterm 0 (getlines newregions) $ + inAreaAbove isterm 0 (concat newlines) $ return () - go (orighandles, newregions) newwidth + go (orighandles, newregions, newlines) newwidth EndSignal () -> return () - getlines = concatMap (reverse . regionLines) readRegions :: [ConsoleRegionHandle] -> STM [Region] readRegions = mapM (\(ConsoleRegionHandle h) -> readTVar h) -- Wait for any changes to the region list, eg adding or removing a handle. regionListWaiter :: RegionSnapshot -> STM RegionSnapshot -regionListWaiter (orighandles, _origregions) = do +regionListWaiter (orighandles, _origregions, origlines) = do handles <- readTMVar regionList if handles == orighandles then retry else do rs <- readRegions handles - return (handles, rs) - + return (handles, rs, origlines) + -- Wait for any changes to any of the regions currently in the region list. -regionWaiter :: RegionSnapshot -> STM RegionSnapshot -regionWaiter (orighandles, origregions) = do +regionWaiter :: RegionSnapshot -> Width -> STM RegionSnapshot +regionWaiter (orighandles, _origregions, origlines) width = do rs <- readRegions orighandles - if rs == origregions - then retry - else return (orighandles, rs) + newlines <- mapM getr (zip rs (origlines ++ repeat [T.empty])) + unless (newlines /= origlines) + retry + return (orighandles, rs, newlines) + where + getr (r, ols) = case regionContent r of + RegionContent _ -> reverse <$> readTVar (regionLines r) + RegionContentSTM a -> do + c <- a + let ls = reverse $ calcRegionLines c width + when (ls /= ols) $ + writeTVar (regionLines r) ls + return ls -- This is not an optimal screen update like curses can do, but it's -- pretty efficient, most of the time! diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,4 +0,0 @@ -It would be nice to have regions whose content was determined by running a -STM Text action. Such regions should update whenever the values that action -accessed change. Could be used for such things as spreadsheets. -I have this mostly done in the stmregions git branch, but not quite working. 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.2.0 +Version: 1.3.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess @@ -28,6 +28,7 @@ demo2.hs demo3.hs aptdemo.hs + stmdemo.hs Library GHC-Options: -Wall -fno-warn-tabs -O2 diff --git a/demo.hs b/demo.hs --- a/demo.hs +++ b/demo.hs @@ -1,8 +1,11 @@ import Control.Concurrent.Async import Control.Concurrent +import Control.Concurrent.STM import System.Console.Concurrent import System.Console.Regions import System.Process +import qualified Data.Text as T +import Data.List main = displayConsoleRegions $ do mapConcurrently download [1..5] @@ -25,8 +28,8 @@ | c < 1 = finishConsoleRegion r (basemsg ++ " done!\n Took xxx seconds.") | otherwise = do - threadDelay 1000000 appendConsoleRegion r " ... " + threadDelay 1000000 go (c-1) r ls :: IO () @@ -37,5 +40,3 @@ _ <- waitForProcessConcurrent p outputConcurrent "<<< ls is done!\n" return () - - diff --git a/demo2.hs b/demo2.hs --- a/demo2.hs +++ b/demo2.hs @@ -2,11 +2,17 @@ import Control.Concurrent import System.Console.Concurrent import System.Console.Regions +import System.Console.Terminal.Size +import qualified Data.Text as T +import Control.Concurrent.STM +import Control.Applicative +import Data.Time.Clock +import Control.Monad main = displayConsoleRegions $ mapConcurrently id [ spinner 100 1 "Pinwheels!!" setConsoleRegion "/-\\|" (withtitle 1) , spinner 100 1 "Bubbles!!!!" setConsoleRegion ".oOo." (withtitle 1) - , spinner 100 1 "Dots......!" appendConsoleRegion "." (const (take 1)) + , spinner 100 1 "Dots......!" appendConsoleRegion "." (const (take 3)) , spinner 30 2 "KleisiFish?" setConsoleRegion " <=< <=< " (withtitle 10) , spinner 10 9 "Countdowns!" setConsoleRegion (reverse [1..10]) diff --git a/stmdemo.hs b/stmdemo.hs new file mode 100644 --- /dev/null +++ b/stmdemo.hs @@ -0,0 +1,49 @@ +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 +import Data.Time.Clock +import Control.Monad +import Data.Monoid + +main :: IO () +main = void $ displayConsoleRegions $ mapConcurrently id + [ infoRegion + , clockRegion + ] + +infoRegion :: IO () +infoRegion = do + r <- openConsoleRegion Linear + setConsoleRegion r $ do + sz <- readTVar consoleSize + regions <- readTMVar regionList + return $ T.pack $ unwords + [ "size:" + , show (width sz) + , "x" + , show (height sz) + , "regions: " + , show (length regions) + ] + +timeDisplay :: TVar UTCTime -> STM T.Text +timeDisplay tv = T.pack . show <$> readTVar tv + +clockRegion :: IO () +clockRegion = do + tv <- atomically . newTVar =<< getCurrentTime + void $ atomically $ openConsoleRegionSTM Linear . rightAlign + =<< newConsoleRegionSTM Linear (timeDisplay tv) + forever $ do + threadDelay 1000000 -- 1 sec + atomically . (writeTVar tv) =<< getCurrentTime + +rightAlign :: ConsoleRegionHandle -> STM T.Text +rightAlign r = do + t <- readRegionContent r + w <- consoleWidth + return (T.replicate (w - T.length t) (T.singleton ' ') <> t)