concurrent-output-1.4.0: stmdemo.hs

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
	, growingDots
	]

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 $ do
		r <- openConsoleRegion Linear
		setConsoleRegion r (timeDisplay tv)
		rightAlign r
	forever $ do
		threadDelay 1000000 -- 1 sec
		atomically . (writeTVar tv) =<< getCurrentTime

rightAlign :: ConsoleRegion -> STM ()
rightAlign r = tuneDisplay r $ \t -> do
        w <- consoleWidth
        return (T.replicate (w - T.length t) (T.singleton ' ') <> t)

growingDots = withConsoleRegion Linear $ \r -> do
	atomically $ rightAlign r
	forever $ do
		appendConsoleRegion r "."
		threadDelay (100000)