From: Mart Lubbers Date: Fri, 15 Apr 2016 08:15:15 +0000 (+0200) Subject: rwst done, rws to go X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=e402533a984929c6cd9a27efbc144313b7c33c8e;p=cc1516.git rwst done, rws to go --- diff --git a/RWST.dcl b/RWST.dcl new file mode 100644 index 0000000..1a5b3b2 --- /dev/null +++ b/RWST.dcl @@ -0,0 +1,46 @@ +definition module RWST + +from Control.Applicative import class Applicative +from Control.Monad import class Monad +from Data.Void import :: Void +from Data.Functor import class Functor +from Data.Functor.Identity import :: Identity +from Data.Monoid import class Monoid, class Semigroup + +:: RWS r w s a :== RWST r w s Identity a + +// The RWST monad transformer +:: RWST r w s m a = RWST (r s -> m (a, s, w)) + +instance Functor (RWST r w s m) | Monad m & Monoid w +instance Applicative (RWST r w s m) | Monad m & Monoid w +instance Monad (RWST r w s m) | Monad m & Monoid w + +runRWST :: (RWST r w s m a) r s -> m (a, s, w) +evalRWST :: (RWST r w s m a) r s -> m (a, w) | Monad m +execRWST :: (RWST r w s m a) r s -> m (s, w) | Monad m +mapRWST :: ((m (a, s, w)) -> n (b, s, w`)) (RWST r w s m a) -> RWST r w` s n b +withRWST :: (r` -> s -> (r, s)) (RWST r w s m a) -> RWST r` w s m a + +// Reader operations +ask :: RWST r w s m r | Monoid w & Monad m +local :: (r -> r) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m +asks :: (r -> a) -> RWST r w s m a | Monoid w & Monad m + +// Writer operations +tell :: w -> RWST r w s m Void | Monoid w & Monad m +listen :: (RWST r w s m a) -> RWST r w s m (a, w) | Monoid w & Monad m +pass :: (RWST r w s m (a, w -> w)) -> RWST r w s m a | Monoid w & Monad m +listens :: (w -> b) (RWST r w s m a) -> RWST r w s m (a, b)| Monoid w & Monad m +censor :: (w -> w) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m + +// State operations +get :: RWST r w s m s | Monoid w & Monad m +put :: s -> RWST r w s m Void | Monoid w & Monad m +modify :: (s -> s) -> RWST r w s m Void | Monoid w & Monad m +gets :: (s -> a) -> RWST r w s m a | Monoid w & Monad m + +// Lifting other operations +liftCallCC :: ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a | Monoid w +liftCallCC` :: ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a | Monoid w +liftCatch :: ((m (a,s,w)) (e -> m (a,s,w)) -> m (a,s,w)) (RWST l w s m a) (e -> RWST l w s m a) -> RWST l w s m a diff --git a/RWST.icl b/RWST.icl new file mode 100644 index 0000000..4b38482 --- /dev/null +++ b/RWST.icl @@ -0,0 +1,94 @@ +implementation module RWST + +import StdTuple + +from Data.Func import $ +import Data.Void +import Data.Functor.Identity +import Data.Functor +import Data.Monoid +import Control.Monad +import Control.Applicative + + +// The RWST monad transformer +:: RWST r w s m a = RWST (r s -> m (a, s, w)) + +instance Functor (RWST r w s m) | Monad m & Monoid w where + fmap f m = liftM f m + +instance Applicative (RWST r w s m) | Monad m & Monoid w where + pure a = RWST \_ s->pure (a, s, mempty) + (<*>) mf mx = ap mf mx + +instance Monad (RWST r w s m) | Monad m & Monoid w where + bind m k = RWST \r s->runRWST m r s + >>= \(a, s`, w)->runRWST (k a) r s` + >>= \(b, s``,w`)->pure (b, s``, mappend w w`) + +runRWST :: (RWST r w s m a) r s -> m (a, s, w) +runRWST (RWST f) r s = f r s + +evalRWST :: (RWST r w s m a) r s -> m (a, w) | Monad m +evalRWST m r s = runRWST m r s >>= \(a, _, w)->pure (a, w) + +execRWST :: (RWST r w s m a) r s -> m (s, w) | Monad m +execRWST m r s = runRWST m r s >>= \(_, s`, w)->pure (s, w) + +mapRWST :: ((m (a, s, w)) -> n (b, s, w`)) (RWST r w s m a) -> RWST r w` s n b +mapRWST f m = RWST \r s->f $ runRWST m r s + +withRWST :: (r` -> s -> (r, s)) (RWST r w s m a) -> RWST r` w s m a +withRWST f m = RWST \r s->uncurry (runRWST m) $ f r s + +// Reader operations +ask :: RWST r w s m r | Monoid w & Monad m +ask = RWST \r s->pure (r, s, mempty) + +local :: (r -> r) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m +local f m = RWST \r s->runRWST m (f r) s + +asks :: (r -> a) -> RWST r w s m a | Monoid w & Monad m +asks f = ask >>= \r->pure $ f r + +// Writer operations +tell :: w -> RWST r w s m Void | Monoid w & Monad m +tell w = RWST \_ s->pure (Void, s,w) + +listen :: (RWST r w s m a) -> RWST r w s m (a, w) | Monoid w & Monad m +listen m = RWST \r s->runRWST m r s >>= \(a, s`, w)->pure ((a, w), s`, w) + +pass :: (RWST r w s m (a, w -> w)) -> RWST r w s m a | Monoid w & Monad m +pass m = RWST \r s->runRWST m r s >>= \((a, f), s`, w)->pure (a, s`, f w) + +listens :: (w -> b) (RWST r w s m a) -> RWST r w s m (a, b)| Monoid w & Monad m +listens f m = listen m >>= \(a, w)->pure (a, f w) + +censor :: (w -> w) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m +censor f m = pass $ m >>= \a->pure (a, f) + +// State operation +get :: RWST r w s m s | Monoid w & Monad m +get = RWST \_ s->pure (s, s, mempty) + +put :: s -> RWST r w s m Void | Monoid w & Monad m +put s = RWST \_ _->pure (Void, s, mempty) + +modify :: (s -> s) -> RWST r w s m Void | Monoid w & Monad m +modify f = get >>= \s->put $ f s + +gets :: (s -> a) -> RWST r w s m a | Monoid w & Monad m +gets f = get >>= \s->pure $ f s + +// Lifting other operations +liftCallCC :: ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a | Monoid w +liftCallCC callCC f = RWST \r s->callCC + \c->runRWST (f $ \a->RWST \_ _->c (a, s, mempty)) r s + +liftCallCC` :: ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a | Monoid w +liftCallCC` callCC f = RWST \r s->callCC + \c->runRWST (f $ \a->RWST \_ s`->c (a, s`, mempty)) r s + +liftCatch :: ((m (a,s,w)) (e -> m (a,s,w)) -> m (a,s,w)) (RWST l w s m a) (e -> RWST l w s m a) -> RWST l w s m a +liftCatch catchError m h = RWST \r s->catchError + (runRWST m r s) (\e->runRWST (h e) r s) diff --git a/rwst.dcl b/rwst.dcl deleted file mode 100644 index 9afc81c..0000000 --- a/rwst.dcl +++ /dev/null @@ -1,12 +0,0 @@ -definition module rwst - -from Data.Functor import class Functor -from Data.Monoid import class Monoid, class Semigroup -from Control.Applicative import class Applicative -from Control.Monad import class Monad - -:: RWST r w s m a - -instance Functor (RWST r w s m) | Monad m & Monoid w -instance Applicative (RWST r w s m) | Monad m & Monoid w -instance Monad (RWST r w s m) | Monad m & Monoid w diff --git a/rwst.icl b/rwst.icl deleted file mode 100644 index e5c1d7c..0000000 --- a/rwst.icl +++ /dev/null @@ -1,27 +0,0 @@ -implementation module rwst - -from Data.Func import $ -import Data.Functor -import Data.Monoid -import Control.Monad -import Control.Applicative - - -Start = "Test" - -:: RWST r w s m a = RWST (r s -> m (a, s, w)) - -runRWST :: (RWST r w s m a) r s -> m (a, s, w) -runRWST (RWST f) r s = f r s - -instance Functor (RWST r w s m) | Monad m & Monoid w where - fmap f m = liftM f m - -instance Applicative (RWST r w s m) | Monad m & Monoid w where - pure a = RWST \_ s->pure (a, s, mempty) - (<*>) mf mx = ap mf mx - -instance Monad (RWST r w s m) | Monad m & Monoid w where - bind m k = RWST \r s->runRWST m r s - >>= \(a, s`, w)->runRWST (k a) r s` - >>= \(b, s``,w`)->pure (b, s``, mappend w w`)