1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
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
import System.Process
main :: IO ()
main = void $ displayConsoleRegions $ do
void titleRegion
ir <- infoRegion
cr <- clockRegion
rr <- rulerRegion
growingDots `concurrently` runBash
mapM_ closeConsoleRegion [ir, cr]
titleRegion :: IO ConsoleRegion
titleRegion = do
r <- openConsoleRegion Linear
setConsoleRegion r "STM demo!"
return r
infoRegion :: IO ConsoleRegion
infoRegion = do
r <- openConsoleRegion Linear
setConsoleRegion r $ do
w <- consoleWidth
h <- 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
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]
rightAlign :: ConsoleRegion -> STM ()
rightAlign r = tuneDisplay r $ \t -> do
w <- consoleWidth
return (T.replicate (w - T.length t) (T.singleton ' ') <> t)
growingDots :: IO ()
growingDots = withConsoleRegion Linear $ \r -> do
atomically $ rightAlign r
width <- atomically consoleWidth
void $ replicateM width $ do
appendConsoleRegion r "."
threadDelay (100000)
runBash :: IO ()
runBash = do
-- Wait for growingDots to display some.
threadDelay 1000000
-- Temporarily clear whatever console regions are open.
rs <- waitDisplayChange $ swapTMVar regionList []
putStrLn "We interrupt this demo to run a shell prompt. exit to continue!"
callCommand "bash"
-- Restore the console regions.
void $ atomically $ swapTMVar regionList rs
|
