expand definitions of Applicative and Alternative methods (fixes #4)
authorRoss Paterson <ross@soi.city.ac.uk>
Sun, 21 Jun 2015 14:17:15 +0000 (14:17 +0000)
committerRoss Paterson <ross@soi.city.ac.uk>
Sun, 21 Jun 2015 14:17:15 +0000 (14:17 +0000)
Control/Monad/Trans/Except.hs
Control/Monad/Trans/Maybe.hs
Control/Monad/Trans/RWS/Lazy.hs
Control/Monad/Trans/RWS/Strict.hs
Control/Monad/Trans/State/Lazy.hs
Control/Monad/Trans/State/Strict.hs

index 31d6b68..65d41f8 100644 (file)
@@ -170,8 +170,12 @@ instance (Functor m, Monad m) => Applicative (ExceptT e m) where
                     Right x -> return (Right (k x))
 
 instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where
                     Right x -> return (Right (k x))
 
 instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where
-    empty = mzero
-    (<|>) = mplus
+    empty = ExceptT $ return (Left mempty)
+    ExceptT mx <|> ExceptT my = ExceptT $ do
+        ex <- mx
+        case ex of
+            Left e -> liftM (either (Left . mappend e) Right) my
+            Right x -> return (Right x)
 
 instance (Monad m) => Monad (ExceptT e m) where
     return a = ExceptT $ return (Right a)
 
 instance (Monad m) => Monad (ExceptT e m) where
     return a = ExceptT $ return (Right a)
@@ -184,10 +188,10 @@ instance (Monad m) => Monad (ExceptT e m) where
 
 instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where
     mzero = ExceptT $ return (Left mempty)
 
 instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where
     mzero = ExceptT $ return (Left mempty)
-    ExceptT m `mplus` ExceptT n = ExceptT $ do
-        a <- m
-        case a of
-            Left e -> liftM (either (Left . mappend e) Right) n
+    ExceptT mx `mplus` ExceptT my = ExceptT $ do
+        ex <- mx
+        case ex of
+            Left e -> liftM (either (Left . mappend e) Right) my
             Right x -> return (Right x)
 
 instance (MonadFix m) => MonadFix (ExceptT e m) where
             Right x -> return (Right x)
 
 instance (MonadFix m) => MonadFix (ExceptT e m) where
index adc5282..9e8f5a1 100644 (file)
@@ -111,12 +111,24 @@ instance (Traversable f) => Traversable (MaybeT f) where
     traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a
 
 instance (Functor m, Monad m) => Applicative (MaybeT m) where
     traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a
 
 instance (Functor m, Monad m) => Applicative (MaybeT m) where
-    pure = return
-    (<*>) = ap
+    pure = lift . return
+    mf <*> mx = MaybeT $ do
+        mb_f <- runMaybeT mf
+        case mb_f of
+            Nothing -> return Nothing
+            Just f  -> do
+                mb_x <- runMaybeT mx
+                case mb_x of
+                    Nothing -> return Nothing
+                    Just x  -> return (Just (f x))
+
 instance (Functor m, Monad m) => Alternative (MaybeT m) where
 instance (Functor m, Monad m) => Alternative (MaybeT m) where
-    empty = mzero
-    (<|>) = mplus
+    empty = MaybeT (return Nothing)
+    x <|> y = MaybeT $ do
+        v <- runMaybeT x
+        case v of
+            Nothing -> runMaybeT y
+            Just _  -> return v
 
 instance (Monad m) => Monad (MaybeT m) where
     fail _ = MaybeT (return Nothing)
 
 instance (Monad m) => Monad (MaybeT m) where
     fail _ = MaybeT (return Nothing)
index 8515803..f32dd2b 100644 (file)
@@ -164,12 +164,15 @@ instance (Functor m) => Functor (RWST r w s m) where
         fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s
 
 instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where
         fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s
 
 instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where
-    pure = return
-    (<*>) = ap
+    pure a = RWST $ \ _ s -> return (a, s, mempty)
+    RWST mf <*> RWST mx  = RWST $ \ r s -> do
+        ~(f, s', w)  <- mf r s
+        ~(x, s'',w') <- mx r s'
+        return (f x, s'', w `mappend` w')
 
 instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where
 
 instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where
-    empty = mzero
-    (<|>) = mplus
+    empty = RWST $ \ _ _ -> mzero
+    RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s
 
 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
     return a = RWST $ \ _ s -> return (a, s, mempty)
 
 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
     return a = RWST $ \ _ s -> return (a, s, mempty)
@@ -180,8 +183,8 @@ instance (Monoid w, Monad m) => Monad (RWST r w s m) where
     fail msg = RWST $ \ _ _ -> fail msg
 
 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
     fail msg = RWST $ \ _ _ -> fail msg
 
 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
-    mzero       = RWST $ \ _ _ -> mzero
-    m `mplus` n = RWST $ \ r s -> runRWST m r s `mplus` runRWST n r s
+    mzero = RWST $ \ _ _ -> mzero
+    RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s
 
 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
     mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
 
 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
     mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
@@ -291,7 +294,7 @@ put s = RWST $ \ _ _ -> return ((), s, mempty)
 -- * @'modify' f = 'get' >>= ('put' . f)@
 modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()
 modify f = RWST $ \ _ s -> return ((), f s, mempty)
 -- * @'modify' f = 'get' >>= ('put' . f)@
 modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()
 modify f = RWST $ \ _ s -> return ((), f s, mempty)
+
 -- | Get a specific component of the state, using a projection function
 -- supplied.
 --
 -- | Get a specific component of the state, using a projection function
 -- supplied.
 --
index db47a0c..514d8d4 100644 (file)
@@ -164,12 +164,15 @@ instance (Functor m) => Functor (RWST r w s m) where
         fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s
 
 instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where
         fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s
 
 instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where
-    pure = return
-    (<*>) = ap
+    pure a = RWST $ \ _ s -> return (a, s, mempty)
+    RWST mf <*> RWST mx = RWST $ \ r s -> do
+        (f, s', w)  <- mf r s
+        (x, s'',w') <- mx r s'
+        return (f x, s'', w `mappend` w')
 
 instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where
 
 instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where
-    empty = mzero
-    (<|>) = mplus
+    empty = RWST $ \ _ _ -> mzero
+    RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s
 
 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
     return a = RWST $ \ _ s -> return (a, s, mempty)
 
 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
     return a = RWST $ \ _ s -> return (a, s, mempty)
@@ -180,8 +183,8 @@ instance (Monoid w, Monad m) => Monad (RWST r w s m) where
     fail msg = RWST $ \ _ _ -> fail msg
 
 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
     fail msg = RWST $ \ _ _ -> fail msg
 
 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
-    mzero       = RWST $ \ _ _ -> mzero
-    m `mplus` n = RWST $ \ r s -> runRWST m r s `mplus` runRWST n r s
+    mzero = RWST $ \ _ _ -> mzero
+    RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s
 
 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
     mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
 
 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
     mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
@@ -291,7 +294,7 @@ put s = RWST $ \ _ _ -> return ((), s, mempty)
 -- * @'modify' f = 'get' >>= ('put' . f)@
 modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()
 modify f = RWST $ \ _ s -> return ((), f s, mempty)
 -- * @'modify' f = 'get' >>= ('put' . f)@
 modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()
 modify f = RWST $ \ _ s -> return ((), f s, mempty)
+
 -- | Get a specific component of the state, using a projection function
 -- supplied.
 --
 -- | Get a specific component of the state, using a projection function
 -- supplied.
 --
index 34b792e..460515b 100644 (file)
@@ -185,15 +185,19 @@ instance (Functor m) => Functor (StateT s m) where
         fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s
 
 instance (Functor m, Monad m) => Applicative (StateT s m) where
         fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s
 
 instance (Functor m, Monad m) => Applicative (StateT s m) where
-    pure = return
-    (<*>) = ap
+    pure a = StateT $ \ s -> return (a, s)
+    StateT mf <*> StateT mx = StateT $ \ s -> do
+        ~(f, s') <- mf s
+        ~(x, s'') <- mx s'
+        return (f x, s'')
+    {-# INLINE (<*>) #-}
 
 instance (Functor m, MonadPlus m) => Alternative (StateT s m) where
 
 instance (Functor m, MonadPlus m) => Alternative (StateT s m) where
-    empty = mzero
-    (<|>) = mplus
+    empty = StateT $ \ _ -> mzero
+    StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s
 
 instance (Monad m) => Monad (StateT s m) where
 
 instance (Monad m) => Monad (StateT s m) where
-    return a = state $ \ s -> (a, s)
+    return a = StateT $ \ s -> return (a, s)
     m >>= k  = StateT $ \ s -> do
         ~(a, s') <- runStateT m s
         runStateT (k a) s'
     m >>= k  = StateT $ \ s -> do
         ~(a, s') <- runStateT m s
         runStateT (k a) s'
@@ -201,7 +205,7 @@ instance (Monad m) => Monad (StateT s m) where
 
 instance (MonadPlus m) => MonadPlus (StateT s m) where
     mzero       = StateT $ \ _ -> mzero
 
 instance (MonadPlus m) => MonadPlus (StateT s m) where
     mzero       = StateT $ \ _ -> mzero
-    m `mplus` n = StateT $ \ s -> runStateT m s `mplus` runStateT n s
+    StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s
 
 instance (MonadFix m) => MonadFix (StateT s m) where
     mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s
 
 instance (MonadFix m) => MonadFix (StateT s m) where
     mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s
index cb51374..639696b 100644 (file)
@@ -182,15 +182,19 @@ instance (Functor m) => Functor (StateT s m) where
         fmap (\ (a, s') -> (f a, s')) $ runStateT m s
 
 instance (Functor m, Monad m) => Applicative (StateT s m) where
         fmap (\ (a, s') -> (f a, s')) $ runStateT m s
 
 instance (Functor m, Monad m) => Applicative (StateT s m) where
-    pure = return
-    (<*>) = ap
+    pure a = StateT $ \ s -> return (a, s)
+    StateT mf <*> StateT mx = StateT $ \ s -> do
+        (f, s') <- mf s
+        (x, s'') <- mx s'
+        return (f x, s'')
+    {-# INLINE (<*>) #-}
 
 instance (Functor m, MonadPlus m) => Alternative (StateT s m) where
 
 instance (Functor m, MonadPlus m) => Alternative (StateT s m) where
-    empty = mzero
-    (<|>) = mplus
+    empty = StateT $ \ _ -> mzero
+    StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s
 
 instance (Monad m) => Monad (StateT s m) where
 
 instance (Monad m) => Monad (StateT s m) where
-    return a = state $ \ s -> (a, s)
+    return a = StateT $ \ s -> return (a, s)
     m >>= k  = StateT $ \ s -> do
         (a, s') <- runStateT m s
         runStateT (k a) s'
     m >>= k  = StateT $ \ s -> do
         (a, s') <- runStateT m s
         runStateT (k a) s'