Re: awaitEval in Concurrent Haskell

17 Feb 2003

      A couple of hours ago, I wrote (in reponse to Claus Reinke's suggestion):
...
Thanks for this further suggestion.  A solution along these lines 
might be
possible, but it would still be restricted ...
Actually a mild variant of Claus's proposal seems to work out
quite well.  Another way to avoid the problems with types is
to use a multi-parameter type class.  Little example attached.

So, thanks again Claus!

Regards
Colin R

-- A mini-experiment in concurrent data-driven assertions.
-- Colin Runciman after Claus Reinke after Andy Gill after ...
-- February 2003

import Control.Concurrent
import Char(isLower)
import System.IO.Unsafe(unsafePerformIO)

-- Each type a over which assertions are to be made is
-- encoded using a metatype b.

class Assert a b | a -> b, b -> a where
  assertW :: MVar b -> a -> a
  assertR :: MVar b -> a

assert :: Assert a b => String -> (a->Bool) -> a -> a
assert s p x = unsafePerformIO $ do
                 mv <- newEmptyMVar
		 forkIO $ check s p (assertR mv)
		 return $ assertW mv x

check :: String -> (a -> Bool) -> a -> IO ()
check s p x | p x       = return ()
            | otherwise = putStrLn $ "assertion failure: " ++ s

-- We can use assertions over characters, encoded as themselves.

instance Assert Char Char where
  assertW mv c = unsafePerformIO $ do
                   putMVar mv c
		   return c
  assertR mv   = unsafePerformIO $ do
                   c <- takeMVar mv
		   return c

-- Here's the metatype encoding for lists; similar definitions
-- would be needed for other structured types.

data MetaList a = Nil
                | Cons (MVar a) (MVar (MetaList a))

instance Assert a b => Assert [a] (MetaList b) where
  assertW mv []     = unsafePerformIO $ do
                        putMVar mv Nil
		        return []
  assertW mv (x:xs) = unsafePerformIO $ do
                        mvx  <- newEmptyMVar
			mvxs <- newEmptyMVar
			putMVar mv (Cons mvx mvxs)
			return (assertW mvx x : assertW mvxs xs)
  assertR mv        = unsafePerformIO $ do
                        ml <- takeMVar mv
			return $ case ml of
			         Nil ->
				   []
			         (Cons mvx mvxs) ->
				   (assertR mvx : assertR mvxs)

-- Finally, a simple example application.

singleCaseWords :: String -> Bool
singleCaseWords  xs = all unmixed (words xs)

unmixed :: String -> Bool
unmixed "" = True
unmixed (c:cs) | isLower c = all isLower cs
               | otherwise = not (any isLower cs)

main = do
  input <- getContents
  putStr (assert "single-case words" singleCaseWords input)