Ticket #5943: mvarBug.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Data.IORef
import Data.Maybe
import Prelude hiding (until)
import System.Mem.Weak

newtype Signal a = S (IO a) deriving (Functor, Applicative, Monad)
type UpdatePool = [Weak (IO (), IO ())]
newtype SignalGen a = SG { unSG :: IORef UpdatePool -> IO a }
data Phase a = Ready a | Updated a a

instance Functor SignalGen where
    fmap = liftM

instance Applicative SignalGen where
    pure = return
    (<*>) = ap

instance Monad SignalGen where
    return x = SG $ \_ -> return x
    SG g >>= f = SG $ \p -> g p >>= \x -> unSG (f x) p

instance MonadFix SignalGen where
    mfix f = SG $ \p -> mfix $ \x -> unSG (f x) p

start :: SignalGen (Signal a) -- ^ the generator of the top-level signal
      -> IO (IO a)            -- ^ the computation to sample the signal
start (SG gen) = do
    pool <- newIORef []
    S sample <- gen pool
    return $ do
        print "res <- sample"
        res <- sample
        print "superstep pool"
        superstep pool
        print "return res"
        return res

-- | Performing the two-phase superstep.
superstep :: IORef UpdatePool -> IO ()
superstep pool = loop id []
  where
    deref ptr = (fmap.fmap) ((,) ptr) (deRefWeak ptr)
    loop getPtrs final = do
      print "(ptrs,acts) <- unzip.catMaybes <$> (mapM deref =<< readIORef pool)"
      (ptrs,acts) <- unzip.catMaybes <$> (mapM deref =<< readIORef pool)
      print "case acts of"
      case acts of
          [] -> do
              print "[] -> do sequence_ final"
              sequence_ final
              print "writeIORef pool (getPtrs []"
              writeIORef pool (getPtrs [])
              print "done: writeIORef pool (getPtrs []"
          _  -> do
              print "_  -> do writeIORef pool []"
              writeIORef pool []
              print "mapM_ fst acts"
              mapM_ fst acts
              print "loop ((ptrs++) . getPtrs) (mapM_ snd acts : final)"
              loop ((ptrs++) . getPtrs) (mapM_ snd acts : final)
              print "done: loop ((ptrs++) . getPtrs) (mapM_ snd acts : final)"

delay :: a                    -- ^ initial output at creation time
      -> Signal a             -- ^ the signal to delay
      -> SignalGen (Signal a) -- ^ the delayed signal
delay x0 (S s) = SG $ \pool -> do
  print "ref <- newIORef (Ready x0)"
  ref <- newIORef (Ready x0)
  let update x = print "s >>= \\x' -> x' `seq`" >> s >>= \x' -> x' `seq` (print "    writeIORef ref (Updated x' x)" >> writeIORef ref (Updated x' x))
      upd = print "readIORef ref >>= \v -> case v of" >> readIORef ref >>= \v -> case v of
              Ready x -> print "Ready x -> update x" >> update x
              _       -> print "_       -> return ()" >> return ()

      fin = print "readIORef ref >>= \v -> case v o" >> readIORef ref >>= \v -> case v of
              Updated x _ -> print "Updated x _ -> writeIORef ref $! Ready x" >> (writeIORef ref $! Ready x)
              _           -> error "Signal not updated!"

      sig = S $ print "readIORef ref >>= \v -> case v of" >> readIORef ref >>= \v -> case v of
              Ready x     -> print "Ready x     -> return x" >> return x
              Updated _ x -> print "Updated _ x -> return x" >> return x
  print "updateActions <- mkWeak sig (upd,fin) Nothing"
  updateActions <- mkWeak sig (upd,fin) Nothing
  print "modifyIORef pool (updateActions:)"
  modifyIORef pool (updateActions:)
  print "return sig"
  return sig


stateful :: a                    -- ^ initial state
         -> (a -> a)             -- ^ state transformation
         -> SignalGen (Signal a)
stateful x0 f = mfix $ \sig -> delay x0 (f <$> sig)

main = do
    net <- start $ stateful 0 (1+)
    print "1st iteration"
    net -- ok for first time
    print "2nd iteration"
    net -- error: thread blocked indefinitely in an MVar operation