scslab/lio — pull request #10 by deian (2012-03-22 08:07:04+00:00)
Title: fix tolabeled bug

Alejandro was right, there was a bug. Here is a simpler version of what he did. Attached is a simple patch. In the scope of think the toLabeledThunk approach is more general, but this is simpler (simply collapse all exceptions within to Labeled to 'Nothing' and thus remove all entropy of exceptions). With the addition of gates and fix of the mask and this bug, I think it's time to push this to hackage.

{-# LANGUAGE ScopedTypeVariables #-}
import Prelude hiding (catch)
import LIO
import LIO.DCLabel
import LIO.LIORef
import LIO.MonadCatch
import DCLabel.PrettyShow

import Control.Monad (when, forM_)

main = evalDC' $ do
lRef <- newLIORef lbot ""
hRef <- newLIORef ltop "secret"
-- brute force:
forM_ ["fun", "secret"] $ \guess -> do
stash <- readLIORef lRef
writeLIORef lRef $ stash ++ "\n" ++ guess ++ ":"
discard ltop $ do
catch ( discard ltop $ do
secret <- readLIORef hRef
when (secret == guess) $ throwIO . userError $ guess
return ()
) (\(e :: IOError) -> return ())
l <- getLabel
when (l == lbot) $ do stash <- readLIORef lRef
writeLIORef lRef $ stash ++ "no!"
readLIORef lRef
where evalDC' act = do (r,l) <- evalDC act
putStrLn r
putStrLn $ "label = " ++ prettyShow l