Minimal Pure MVar

mvar.hs

{-# LANGUAGE ExistentialQuantification #-}
import           Control.Monad.Free

data MVar a = Empty | Val a

data MVarOps next = forall a. New (MVar a -> next)
                    | forall a. Put (MVar a) a next
                    | forall a. Take (MVar a) (a -> next)

-- GHC won't derive this for us :(
instance Functor MVarOps where
  fmap f (New g) = New (f . g)
  fmap f (Put v a x) = Put v a (f x)
  fmap f (Take v g) = Take v (f . g)

type MVarM = Free MVarOps

newMVar :: MVarM (MVar a)
newMVar = liftF $ New id

putMVar :: MVar a -> a -> MVarM ()
putMVar v a = liftF $ Put v a ()

takeMVar :: MVar a -> MVarM a
takeMVar v = liftF $ Take v id

-- A conversion of the example at http://hackage.haskell.org/package/base-4.8.0.0/docs/Control-Concurrent-MVar.html

data SkipChan a = SkipChan (MVar (a, [MVar ()])) (MVar ())

newSkipChan :: MVarM (SkipChan a)
newSkipChan = do
  sem <- newMVar
  main <- newMVar
  putMVar main (undefined, [sem])
  return $ SkipChan main sem

putSkipChan :: SkipChan a -> a -> MVarM ()
putSkipChan (SkipChan main _) v = do
  (_, sems) <- takeMVar main
  putMVar main (v, [])
  mapM_ (\sem -> putMVar sem ()) sems


getSkipChan :: SkipChan a -> MVarM a
getSkipChan (SkipChan main sem) = do
    takeMVar sem
    (v, sems) <- takeMVar main
    putMVar main (v, sem:sems)
    return v

dupSkipChan :: SkipChan a -> MVarM (SkipChan a)
dupSkipChan (SkipChan main _) = do
    sem <- newMVar
    (v, sems) <- takeMVar main
    putMVar main (v, sem:sems)
    return (SkipChan main sem)