{- | Following an idea by Dominique Devriese: <http://www.haskell.org/pipermail/libraries/2013-June/020185.html> -} {- How about fancy infix operators like: do ref <:- a b <- Ref.read ref ? -} module Data.Ref where import Data.IORef (newIORef, readIORef, writeIORef, ) import Data.STRef (newSTRef, readSTRef, writeSTRef, ) import Control.Concurrent.STM.TVar (newTVar, readTVar, writeTVar, ) import Control.Concurrent.STM (STM, ) import Control.Monad.ST (ST) import Control.Monad (liftM) import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.IO.Class as MIO import qualified Control.Monad.Trans.RWS.Lazy as MRWSL import qualified Control.Monad.Trans.RWS.Strict as MRWSS import qualified Control.Monad.Trans.State.Lazy as MSL import qualified Control.Monad.Trans.State.Strict as MSS import qualified Control.Monad.Trans.Writer.Lazy as MWL import qualified Control.Monad.Trans.Writer.Strict as MWS import qualified Control.Monad.Trans.Cont as MC import qualified Control.Monad.Trans.Error as ME import qualified Control.Monad.Trans.Except as MEx import qualified Control.Monad.Trans.Maybe as MM import qualified Control.Monad.Trans.Reader as MR import qualified Control.Monad.Trans.Identity as MI import qualified Data.Accessor.Basic as Accessor import Data.Monoid (Monoid) import Prelude hiding (read) data T m a = Cons { write :: a -> m (), read :: m a } modify :: C m => T m a -> (a -> a) -> m () modify ref f = write ref . f =<< read ref focus :: C m => Accessor.T a b -> T m a -> T m b focus acc ref = Cons (modify ref . Accessor.set acc) (liftM (Accessor.get acc) $ read ref) newCons :: C m => (a -> m ref) -> (ref -> a -> m ()) -> (ref -> m a) -> a -> m (T m a) newCons nw wr rd = liftM (\r -> Cons (wr r) (rd r)) . nw class Monad m => C m where new :: a -> m (T m a) instance C IO where new = newCons newIORef writeIORef readIORef instance C (ST s) where new = newCons newSTRef writeSTRef readSTRef instance C STM where new = newCons newTVar writeTVar readTVar {- mapMonad :: (Monad m, Monad n) => (forall b. m b -> n b) -> T m a -> T n a mapMonad lft (Cons wr rd) = Cons (lft . wr) (lft rd) -} lift :: (Monad m, MT.MonadTrans t) => T m a -> T (t m) a lift (Cons wr rd) = Cons (MT.lift .wr) (MT.lift rd) liftIO :: (MIO.MonadIO m) => T IO a -> T m a liftIO (Cons wr rd) = Cons (MIO.liftIO .wr) (MIO.liftIO rd) newLifted :: (C m, MT.MonadTrans t) => a -> t m (T (t m) a) newLifted = MT.lift . liftM lift . new instance C m => C (MI.IdentityT m) where new = newLifted instance C m => C (MM.MaybeT m) where new = newLifted instance (ME.Error e, C m) => C (ME.ErrorT e m) where new = newLifted instance (C m) => C (MEx.ExceptT e m) where new = newLifted instance C m => C (MC.ContT r m) where new = newLifted instance C m => C (MR.ReaderT r m) where new = newLifted instance C m => C (MSS.StateT s m) where new = newLifted instance C m => C (MSL.StateT s m) where new = newLifted instance (Monoid w, C m) => C (MWS.WriterT w m) where new = newLifted instance (Monoid w, C m) => C (MWL.WriterT w m) where new = newLifted instance (Monoid w, C m) => C (MRWSS.RWST r w s m) where new = newLifted instance (Monoid w, C m) => C (MRWSL.RWST r w s m) where new = newLifted -- ToDo: another interesting instance would be Wrapper (StateT Vault)