parconc-examples-0.3: other/correcter.hs

import System.IO
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Data.Char

main = do
  hSetBuffering stdin  NoBuffering
  hSetBuffering stdout NoBuffering
  hSetEcho stdin False
  tvar <- newTVarIO ""
  forkIO (render tvar)
  forkIO (correcter tvar)
  forever $ do
    c <- getChar
    atomically $ do
      s <- readTVar tvar
      writeTVar tvar (s ++ [c])

correcter :: TVar String -> IO ()
correcter tvar = loop ""
 where
  loop current = do
    new <- atomically $ do
       s <- readTVar tvar
       when (s == current) retry
       let s' = correct s
       when (s' == s) retry
       writeTVar tvar s'
       return s'
    loop new

render :: TVar String -> IO ()
render tvar = loop ""
 where
  printit current s = do
     putStr (replicate (length current) '\8')
     putStr s

  loop current = do
    new <- atomically $ do
       s <- readTVar tvar
       when (s == current) retry
       return s
    printit current new
    loop new

-- This function applies an arbitrary function to the input string.
-- It could do all kinds of funky stuff, but right now all it does is
-- capitalise the first character after a full stop.
--
correct :: String -> String
correct s = go s
 where
  go "" = ""
  go ('.':' ':c:s) | isLower c = '.':' ': toUpper c: go s
  go (c:cs) = c : go cs