Added missing Functor, Applicative, Alternative and MonadPlus instances Added Applica...
authorBas van Dijk <v.dijk.bas@gmail.com>
Fri, 11 Nov 2011 17:47:24 +0000 (18:47 +0100)
committerIan Lynagh <igloo@earth.li>
Tue, 24 Jan 2012 19:46:09 +0000 (19:46 +0000)
Control/Applicative.hs
Control/Arrow.hs

index 3a9db61..04e8e9d 100644 (file)
@@ -48,7 +48,7 @@ module Control.Applicative (
 import Prelude hiding (id,(.))
 
 import Control.Category
-import Control.Arrow (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>)))
+import Control.Arrow
 import Control.Monad (liftM, ap, MonadPlus(..))
 #ifndef __NHC__
 import Control.Monad.ST.Safe (ST)
@@ -57,6 +57,16 @@ import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)
 import Data.Functor ((<$>), (<$))
 import Data.Monoid (Monoid(..))
 
+import Text.ParserCombinators.ReadP
+#ifndef __NHC__
+  (ReadP)
+#else
+  (ReadPN)
+#define ReadP (ReadPN b)
+#endif
+
+import Text.ParserCombinators.ReadPrec (ReadPrec)
+
 #ifdef __GLASGOW_HASKELL__
 import GHC.Conc (STM, retry, orElse)
 #endif
@@ -204,6 +214,30 @@ instance Applicative (Either e) where
     Left  e <*> _ = Left e
     Right f <*> r = fmap f r
 
+instance Applicative ReadP where
+    pure = return
+    (<*>) = ap
+
+instance Alternative ReadP where
+    empty = mzero
+    (<|>) = mplus
+
+instance Applicative ReadPrec where
+    pure = return
+    (<*>) = ap
+
+instance Alternative ReadPrec where
+    empty = mzero
+    (<|>) = mplus
+
+instance Arrow a => Applicative (ArrowMonad a) where
+   pure x = ArrowMonad (arr (const x))
+   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
+
+instance ArrowPlus a => Alternative (ArrowMonad a) where
+   empty = ArrowMonad zeroArrow
+   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
+
 -- new instances
 
 newtype Const a b = Const { getConst :: a }
index 8915f09..73dfe3d 100644 (file)
@@ -296,11 +296,18 @@ instance Monad m => ArrowApply (Kleisli m) where
 
 newtype ArrowMonad a b = ArrowMonad (a () b)
 
+instance Arrow a => Functor (ArrowMonad a) where
+    fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f
+
 instance ArrowApply a => Monad (ArrowMonad a) where
     return x = ArrowMonad (arr (\_ -> x))
     ArrowMonad m >>= f = ArrowMonad $
         m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app
 
+instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where
+   mzero = ArrowMonad zeroArrow
+   ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y)
+
 -- | Any instance of 'ArrowApply' can be made into an instance of
 --   'ArrowChoice' by defining 'left' = 'leftApp'.