concurrent-output-1.6.0: stmdemo.hs

import Control.Concurrent.Async
import Control.Concurrent
import System.Console.Regions
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 $ do
	ir <- infoRegion
	cr <- clockRegion
	rr <- rulerRegion
	growingDots
	mapM_ closeConsoleRegion [ir, cr]

infoRegion :: IO ConsoleRegion
infoRegion = do
	r <- openConsoleRegion Linear
	setConsoleRegion r $ do
	 	w <- readTVar consoleWidth
	 	h <- readTVar consoleHeight
		regions <- readTMVar regionList
 		return $ T.pack $ unwords
 			[ "size:"
			, show w
 			, "x"
			, show h
			, "regions: "
			, show (length regions)
 			]
	return r

timeDisplay :: TVar UTCTime -> STM T.Text
timeDisplay tv = T.pack . show <$> readTVar tv

clockRegion :: IO ConsoleRegion
clockRegion = do
	tv <- atomically . newTVar =<< getCurrentTime
	async $ forever $ do
		threadDelay 1000000 -- 1 sec
		atomically . (writeTVar tv) =<< getCurrentTime
	atomically $ do
		r <- openConsoleRegion Linear
		setConsoleRegion r (timeDisplay tv)
		rightAlign r
		return r

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