{- |
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.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 { forall (m :: * -> *) a. T m a -> a -> m ()
write :: a -> m (), forall (m :: * -> *) a. T m a -> m a
read :: m a }

modify :: C m => T m a -> (a -> a) -> m ()
modify :: forall (m :: * -> *) a. C m => T m a -> (a -> a) -> m ()
modify T m a
ref a -> a
f = forall (m :: * -> *) a. T m a -> a -> m ()
write T m a
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. T m a -> m a
read T m a
ref

focus :: C m => Accessor.T a b -> T m a -> T m b
focus :: forall (m :: * -> *) a b. C m => T a b -> T m a -> T m b
focus T a b
acc T m a
ref =
   forall (m :: * -> *) a. (a -> m ()) -> m a -> T m a
Cons
      (forall (m :: * -> *) a. C m => T m a -> (a -> a) -> m ()
modify T m a
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r a. T r a -> a -> r -> r
Accessor.set T a b
acc)
      (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall r a. T r a -> r -> a
Accessor.get T a b
acc) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. T m a -> m a
read T m a
ref)

newCons :: C m =>
   (a -> m ref) -> (ref -> a -> m ()) -> (ref -> m a) ->
   a -> m (T m a)
newCons :: forall (m :: * -> *) a ref.
C m =>
(a -> m ref)
-> (ref -> a -> m ()) -> (ref -> m a) -> a -> m (T m a)
newCons a -> m ref
nw ref -> a -> m ()
wr ref -> m a
rd = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\ref
r -> forall (m :: * -> *) a. (a -> m ()) -> m a -> T m a
Cons (ref -> a -> m ()
wr ref
r) (ref -> m a
rd ref
r)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m ref
nw


class Monad m => C m where
   new :: a -> m (T m a)

instance C IO where
   new :: forall a. a -> IO (T IO a)
new = forall (m :: * -> *) a ref.
C m =>
(a -> m ref)
-> (ref -> a -> m ()) -> (ref -> m a) -> a -> m (T m a)
newCons forall a. a -> IO (IORef a)
newIORef forall a. IORef a -> a -> IO ()
writeIORef forall a. IORef a -> IO a
readIORef

instance C (ST s) where
   new :: forall a. a -> ST s (T (ST s) a)
new = forall (m :: * -> *) a ref.
C m =>
(a -> m ref)
-> (ref -> a -> m ()) -> (ref -> m a) -> a -> m (T m a)
newCons forall a s. a -> ST s (STRef s a)
newSTRef forall s a. STRef s a -> a -> ST s ()
writeSTRef forall s a. STRef s a -> ST s a
readSTRef

instance C STM where
   new :: forall a. a -> STM (T STM a)
new = forall (m :: * -> *) a ref.
C m =>
(a -> m ref)
-> (ref -> a -> m ()) -> (ref -> m a) -> a -> m (T m a)
newCons forall a. a -> STM (TVar a)
newTVar forall a. TVar a -> a -> STM ()
writeTVar forall a. TVar a -> STM a
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 :: forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTrans t) =>
T m a -> T (t m) a
lift (Cons a -> m ()
wr m a
rd) = forall (m :: * -> *) a. (a -> m ()) -> m a -> T m a
Cons (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> m ()
wr) (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift m a
rd)

liftIO :: (MIO.MonadIO m) => T IO a -> T m a
liftIO :: forall (m :: * -> *) a. MonadIO m => T IO a -> T m a
liftIO (Cons a -> IO ()
wr IO a
rd) = forall (m :: * -> *) a. (a -> m ()) -> m a -> T m a
Cons (forall (m :: * -> *) a. MonadIO m => IO a -> m a
MIO.liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> IO ()
wr) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
MIO.liftIO IO a
rd)

newLifted :: (C m, MT.MonadTrans t) => a -> t m (T (t m) a)
newLifted :: forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTrans t) =>
T m a -> T (t m) a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. C m => a -> m (T m a)
new


instance C m => C (MI.IdentityT m) where new :: forall a. a -> IdentityT m (T (IdentityT m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted

instance C m => C (MM.MaybeT m) where new :: forall a. a -> MaybeT m (T (MaybeT m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance (C m) => C (MEx.ExceptT e m) where new :: forall a. a -> ExceptT e m (T (ExceptT e m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted

instance C m => C (MC.ContT r m) where new :: forall a. a -> ContT r m (T (ContT r m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance C m => C (MR.ReaderT r m) where new :: forall a. a -> ReaderT r m (T (ReaderT r m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance C m => C (MSS.StateT s m) where new :: forall a. a -> StateT s m (T (StateT s m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance C m => C (MSL.StateT s m) where new :: forall a. a -> StateT s m (T (StateT s m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance (Monoid w, C m) => C (MWS.WriterT w m) where new :: forall a. a -> WriterT w m (T (WriterT w m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance (Monoid w, C m) => C (MWL.WriterT w m) where new :: forall a. a -> WriterT w m (T (WriterT w m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance (Monoid w, C m) => C (MRWSS.RWST r w s m) where new :: forall a. a -> RWST r w s m (T (RWST r w s m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted
instance (Monoid w, C m) => C (MRWSL.RWST r w s m) where new :: forall a. a -> RWST r w s m (T (RWST r w s m) a)
new = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(C m, MonadTrans t) =>
a -> t m (T (t m) a)
newLifted

-- ToDo: another interesting instance would be Wrapper (StateT Vault)