Add bootstrap for mtl-style libs.

lib/Control/Monad.hm

@@ -42,10 +42,19 @@ module Control.Monad
   , module Data.Functor
   , unsafePerformIO
   , replApply
+  , class Biapplicative
+  , bipure
+  , biapply
+  , (<<*>>)
+  , class Bimonad
+  , bibind
+  , bijoin
   ) where
 
-import Data.Functor (class Functor, map, (<$>))
+import Data.Function (identity)
+import Data.Functor (class Functor, map, (<$>), class Bifunctor, bimap, (<<$>>))
 import Data.Unit (Unit, unit)
+import Data.Tuple (fst, snd)
 
 -----------------------------------------------------------------------------
 -- | Applicative typeclass
@@ -221,9 +230,7 @@ unless :: forall m. Monad m => Boolean -> m () -> m ()
 unless b m = if b then pure () else m
 
 join :: forall m a. Monad m => m (m a) -> m a
-join mma = do
-  ma <- mma
-  ma
+join x = x >>= identity
 
 filterM :: forall m a. Monad m => (a -> m Boolean) -> [a] -> m [a]
 filterM f [] = pure []
@@ -238,4 +245,30 @@ foldM f i [x|xs] = do
   r <- f i x
   foldM f r xs
 
+class Bifunctor f => Biapplicative f where
+  bipure :: forall a b. a -> b -> f a b
+  biapply :: forall a b c d.
+    f (a -> b) (c -> d) -> f a c -> f b d
 
+infixl 4 biapply as <<*>>
+
+instance Biapplicative Tuple2 where
+  bipure x y = (x, y)
+  biapply (f, g) (x, y) = (f x, g y)
+
+class (Biapplicative m, Biapplicative n) => Bimonad m n where
+  bibind :: forall a b c d. (m a b, n a b) -> ((a -> m c d), (b -> n c d)) -> (m c d, n c d)
+
+bijoin :: forall m n a b. Bimonad m n =>
+  (m (m a b) (n a b), n (m a b) (n a b)) -> (m a b, n a b)
+bijoin p = bibind p (identity, identity)
+
+infixl 4 bibind as >>==
+
+bijoin_ :: forall a b. (Tuple2 (Tuple2 a b) (Tuple2 a b), Tuple2 (Tuple2 a b) (Tuple2 a b)) -> (Tuple2 a b, Tuple2 a b)
+bijoin_ = bimap fst snd
+instance Bimonad Tuple2 Tuple2 where
+  bibind (mab, nab) (f, g) = bijoin_ ((bimap f g, bimap f g) <<*>> (mab, nab))
+
+bilift :: forall f a b c d. Biapplicative f => (a -> b) -> (c -> d) -> f a c -> f b d
+bilift f g = biapply (bipure f g)

lib/Control/Monad/Cont/Class.hm

@@ -0,0 +1 @@
+module Control.Monad.Cont.Class where

lib/Control/Monad/Cont/Cont.hm

@@ -0,0 +1,17 @@
+module Control.Monad.Cont.Cont where
+
+import Data.Function
+import Control.Monad.Identity
+
+newtype ContT r m a = ContT ((a -> m r) -> m r)
+unCont :: forall r m a.
+  ContT r m a -> ((a -> m r) -> m r)
+unCont (ContT x) = x
+
+runConT :: forall r m a.
+  ContT r m a -> (a -> m r) -> m r
+runConT (ContT x) k = x k
+
+
+
+type Cont r a = ContT r Identity a

lib/Control/Monad/Error/Either.hm

@@ -0,0 +1,32 @@
+module Control.Monad.Error.Either where
+
+import Data.Function (($))
+import Data.Either (Either(..), either)
+import Control.Monad (class Applicative, class Monad, bind, pure, (<*>), (>>=))
+import Data.Functor (class Functor, map, (<$>))
+import Control.Monad.Trans (class MonadTrans)
+
+data EitherT e m a = EitherT (m (Either e a))
+runEitherT :: forall e m a. EitherT e m a -> m (Either e a)
+runEitherT (EitherT x) = x
+
+eitherT :: forall m a b c. Monad m =>
+  (a -> m c) -> (b -> m c) -> EitherT a m b -> m c
+eitherT f g x = runEitherT x >>= either f g
+
+mapEitherT :: forall m n e e' a b.
+  (m (Either e a) -> n (Either e' b)) -> EitherT e m a -> EitherT e' n b
+mapEitherT f x = EitherT (f (runEitherT x))
+
+instance Functor f => Functor (EitherT e f) where
+  map f e = EitherT $ map f <$> runEitherT e
+
+instance Applicative f => Applicative (EitherT e f) where
+  pure x = EitherT $ pure $ Right x
+  apply f x = EitherT $ pure (<*>) <*> (runEitherT f) <*> (runEitherT x)
+
+instance Monad m => Monad (EitherT e m) where
+  bind x k = EitherT $ bind (runEitherT x) (either (\l -> pure (Left l)) (\v -> runEitherT (k v)))
+
+instance MonadTrans (EitherT e) where
+  lift x = EitherT (map Right x)

lib/Control/Monad/Gen/Class.hm

@@ -0,0 +1 @@
+module Control.Monad.Gen.Class where

lib/Control/Monad/Gen/Gen.hm

@@ -0,0 +1,57 @@
+module Control.Monad.Gen.Gen where
+
+import Control.Monad.Identity
+import Control.Monad.Trans
+import Control.Monad.State.State
+import Control.Monad.State.Class
+import Control.Monad.Reader.Reader
+import Control.Monad.Reader.Class
+import Data.Functor
+import Control.Monad
+import Data.Function
+import Data.Enum
+
+newtype Succ a = Succ (a -> a)
+unSucc :: forall a. Succ a -> a -> a
+unSucc (Succ x) = x
+
+newtype GenT e m a = GenT (ReaderT (Succ e) (StateT e m) a)
+unGenT :: forall e m a. GenT e m a -> ReaderT (Succ e) (StateT e m) a
+unGenT (GenT x) = x
+
+instance Functor f => Functor (GenT e f) where
+  map f x = GenT $ ReaderT \r -> ST \s -> (map $ mapSnd f)
+    let ReaderT x' = unGenT x
+        ST xs = x' r
+    in xs s
+
+instance (Functor f, Monad f) => Applicative (GenT e f) where
+  pure x = GenT (pure x)
+  apply (GenT f) (GenT x) = GenT $ f <*> x
+
+instance Monad m => Monad (GenT e m) where
+  bind (GenT x) k = GenT $ x >>= \a -> unGenT (k a)
+
+instance MonadPlus m => MonadPlus (GenT e m) where
+  mzero = GenT mzero
+  mplus (GenT m) (GenT n) = GenT (mplus m n)
+
+instance MonadPlus m => Alternative (GenT e m) where
+  empty = mzero
+  append = mplus
+
+type Gen e = GenT e Identity
+
+instance MonadTrans (GenT e) where
+  lift x = GenT $ lift $ lift x
+
+instance MonadState s m => MonadState s (GenT e m) where
+  get = GenT $ lift $ lift get
+  put x = GenT $ lift $ lift $ put x
+
+instance MonadReader r m => MonadReader r (GenT e m) where
+  ask = GenT $ lift ask
+  local f x = GenT $ ask >>= \s -> lift $ local f $ unReaderT (unGenT x) s
+
+enumSucc :: forall a. Enum a => Succ a
+enumSucc = Succ succ

lib/Control/Monad/Identity.hm

@@ -0,0 +1,52 @@
+module Control.Monad.Identity where
+
+import Control.Monad (class Applicative, class Monad, liftA1)
+import Data.Monoid (class Monoid, mempty)
+import Data.Traversable (class Traversable)
+import Data.Functor (class Functor, (<$>))
+import Data.Show (class Show, show)
+import Data.Foldable (class Foldable)
+import Data.Semigroup (class Semigroup, (<>))
+import Data.Ord (class Ord, compare)
+import Data.Eq (class Eq, eq)
+import Data.Function (($))
+
+data Identity x = Id x
+runIdentity :: forall a. Identity a -> a
+runIdentity (Id x) = x
+
+instance Functor Identity where
+  map f (Id x) = Id $ f x
+
+instance Applicative Identity where
+  pure = Id
+  apply (Id f) (Id x) = Id $ f x
+
+join_ :: forall a. Identity (Identity a) -> Identity a
+join_ (Id xs) = xs
+instance Monad Identity where
+  bind ma f = join_ $ f <$> ma
+
+instance Show a => Show (Identity a) where
+  show (Id x) = show x
+
+instance Eq a => Eq (Identity a) where
+  eq (Id x) (Id y) = x `eq` y
+
+instance Ord a => Ord (Identity a) where
+  compare (Id x) (Id y) = x `compare` y
+
+instance Semigroup a => Semigroup (Identity a) where
+  append x y = Id (runIdentity x <> runIdentity y)
+
+instance Monoid a => Monoid (Identity a) where
+  mempty = Id mempty
+
+instance Foldable Identity where
+  foldl f i (Id x) = f i x
+  foldr f i (Id x) = f x i
+  foldMap f (Id x) = f x
+
+instance Traversable Identity where
+  traverse f (Id x) = liftA1 Id (f x)
+  sequence (Id x)   = liftA1 Id x

lib/Control/Monad/RWS/RWS.hm

@@ -0,0 +1,42 @@
+module Control.Monad.RWS.RWS where
+
+import Data.Function
+import Data.Tuple
+import Control.Monad.Identity
+import Control.Monad.Trans
+import Data.Monoid
+import Data.Functor
+import Data.Semigroup
+
+newtype RWST r w s m a = RWST (r -> s -> w -> m (a, s, w))
+unRWST :: forall r w s m a. RWST r w s m a -> r -> s -> w -> m (a, s, w)
+unRWST (RWST x) = x
+
+runRWST :: forall r w s m a. Monoid w =>
+  RWST r w s m a -> r -> s -> m (a, s, w)
+runRWST m r s = unRWST m r s mempty
+
+rwsT :: forall r w s m a. Functor m => Semigroup w =>
+  (r -> s -> m (a, s, w)) -> RWST r w s m a
+rwsT f = RWST \r s w -> (\(a, s', w') -> (a, s', w <> w')) <$> f r s
+
+evalRWST :: forall r w s f a. Functor f => Monoid w =>
+  RWST r w s f a -> r -> s -> f (a, w)
+evalRWST f r s = (\(a, _, w) -> (a, w)) <$> runRWST f r s
+
+execRWST :: forall r w s f a. Functor f => Monoid w =>
+  RWST r w s f a -> r -> s -> f (s, w)
+execRWST f r s = (\(_, s', w) -> (s', w)) <$> runRWST f r s
+
+mapRWST :: forall r w w' s m f a b. Functor f => Monoid w => Semigroup w' =>
+  (m (a, s, w) -> f (b, s, w')) -> RWST r w s m a -> RWST r w' s f b
+mapRWST f m = RWST \r s w -> (\(a, s',w') -> (a, s', w <> w')) <$> f (runRWST m r s)
+
+withRWST :: forall r r' w s m a. (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
+withRWST f m = RWST \r s -> uncurry (unRWST m) (f r s)
+
+type RWS r w s = RWST r w s Identity
+
+runRWS :: forall r w s a. Monoid w =>
+  RWS r w s a -> r -> s -> (a, s, w)
+runRWS m r s = runIdentity (runRWST m r s)

lib/Control/Monad/Reader.hm

@@ -1,25 +1,11 @@
-module Control.Monad.Reader where
-
-import Data.Functor (class Functor)
-import Control.Monad (class Applicative, class Monad)
-
-data Reader e a = Reader (e -> a)
-
-runReader :: forall e a. Reader e a -> e -> a
-runReader (Reader r) = r
-
-instance Functor (Reader e) where
-  map f (Reader r) = Reader (\e -> f (r e))
-
-instance Applicative (Reader e) where
-  pure a = Reader (\_ -> a)
-  apply (Reader f) (Reader r) = Reader (\e -> (f e) (r e))
-
-instance Monad (Reader e) where
-  bind (Reader r) f = Reader (\e -> runReader (f (r e)) e)
-
-ask :: forall e. Reader e e
-ask = Reader (\e -> e)
-
-local :: forall e a. (e -> a) -> Reader e a
-local f = Reader (\e -> f e)
+module Control.Monad.Reader (
+  module Control.Monad.Reader.Reader,
+  module Control.Monad.Reader.Class
+) where
+
+import Control.Monad.Reader.Reader ( ReaderT, unReaderT
+                                   , runReaderT, mapReaderT
+                                   , Reader, runReader )
+import Control.Monad.Reader.Class ( class MonadReader
+                                  , ask, local
+                                  , reader, asks )

lib/Control/Monad/Reader/Class.hm

@@ -0,0 +1,39 @@
+module Control.Monad.Reader.Class where
+
+import Control.Monad (class Monad, bind, map, pure)
+import Control.Monad.Trans (lift)
+import Data.Function (flip, ($))
+import Control.Monad.Reader.Reader (ReaderT(..))
+import Control.Monad.State.State (StateT, mapStateT)
+import Control.Monad.Error.Either (EitherT, mapEitherT)
+import Control.Monad.Writer.Writer (WriterT(..))
+
+class Monad m => MonadReader s m | m -> s where
+  ask :: m s
+  local :: forall a. (s -> s) -> m a -> m a
+
+reader :: forall s m a. MonadReader s m =>
+  (s -> a) -> m a
+reader f = do
+  r <- ask
+  pure (f r)
+
+asks :: forall s m a. MonadReader s m =>
+  (s -> a) -> m a
+asks = flip map ask
+
+instance Monad m => MonadReader s (ReaderT s m) where
+  ask = ReaderT $ \s -> pure s
+  local f (ReaderT act) = ReaderT $ \s -> act (f s)
+
+instance MonadReader r m => MonadReader r (StateT s m) where
+  ask = lift ask
+  local f = mapStateT (local f)
+
+instance MonadReader r m => MonadReader r (EitherT e m) where
+  ask = lift ask
+  local x = mapEitherT (local x)
+
+instance MonadReader r m => MonadReader r (WriterT w m) where
+  ask = lift ask
+  local f (WriterT x) = WriterT \w -> local f (x w)