concurrent-output-1.3.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
	]

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)