ghc/interpreter/test/unused/testcvar.hs

   1 -- test:
   2 -- A split-screen program:
   3 --   User input is displayed in top half of screen;
   4 --   Program output in the bottom half of the screen.
   5
   6 module TestCVar(talk) where
   7 import Concurrent(
   8          forkIO, CVar, newCVar, readCVar, writeCVar
   9          )
  10
  11 -- from ansi.hs (modified for Xterm settings)
  12 goto :: Int -> Int -> String
  13 goto x y = "\ESC[" ++ show (y+1) ++ ";" ++ show (x+1) ++ "H"
  14
  15 cls :: String
  16 cls = "\ESC[H\ESC[2J"         -- for Xterm
  17
  18 -- Raw terminal handler:
  19 --  Atomically writes characters to screen at specific coordinates.
  20
  21 type Terminal = CVar (Int,Int,Char)
  22
  23 terminal :: IO Terminal
  24 terminal
  25   = newCVar                  >>= \ buf ->
  26     forkIO (server_loop buf) >>
  27     return buf
  28  where
  29   -- possible optimisation:
  30   --  remember current screen location to let us omit goto sometimes
  31   server_loop buf
  32     = readCVar buf          >>= \ (x,y,c) ->
  33       putStr (goto x y)    >>
  34       putChar c            >>
  35       server_loop buf
  36
  37 -- Window handler:
  38 --  Keeps track of cursor position so that user program doesn't have to.
  39 --  Doesn't do redraw, scrolling, clipping, etc
  40
  41 type DemoWindow = CVar Char
  42
  43 window :: Terminal -> Int -> Int -> IO DemoWindow
  44 window t left top
  45   = newCVar                      >>= \ buf ->
  46     forkIO (server_loop buf left top) >>
  47     return buf
  48  where
  49   server_loop buf x y
  50     = readCVar buf >>= \ c ->
  51       if c == '\n' then
  52         server_loop buf left (y+1)
  53       else
  54         writeCVar t (x,y,c) >>
  55         server_loop buf (x+1) y
  56
  57 put :: DemoWindow -> Char -> IO ()
  58 put w c = writeCVar w c
  59
  60 -- copy input to top of screen, output to bottom of screen
  61 talk :: (Char -> Char) -> IO ()
  62 talk f =
  63   putStr cls     >>
  64   terminal       >>= \ t ->
  65   window t 0 0   >>= \ w1 ->
  66   window t 0 12  >>= \ w2 ->
  67   loop w1 w2
  68  where
  69   loop w1 w2
  70     = getCh        >>= \ c ->
  71       put w1 c     >>
  72       put w2 (f c) >>
  73       loop w1 w2
  74
  75 -- Non-blocking getchar
  76 -- ToDo: find a way to replace the busy wait.
  77 -- (Not easy in Unix!)
  78 getCh :: IO Char
  79 getCh
  80   = primIOAvailable           >>= \ avail ->
  81     if avail then
  82       getChar
  83     else
  84       primWait >>
  85       getCh