X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FApplicative.hs;h=154b591288c4e21088e778c48f63ad4e34510254;hb=b22112520b01c4906eebd0b6894d4bf2665c11e2;hp=e60182d890eac1d76c73530c7a8d2f797edec808;hpb=3f8efa0023b9c92ad7b2f71ba55afc2375320da5;p=ghc-base.git

diff --git a/Control/Applicative.hs b/Control/Applicative.hs
index e60182d..154b591 100644
--- a/Control/Applicative.hs
+++ b/Control/Applicative.hs
@@ -45,6 +45,10 @@ import Control.Monad.Instances ()
 import Data.Functor ((<$>), (<$))
 import Data.Monoid (Monoid(..))
 
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc (STM, retry, orElse)
+#endif
+
 infixl 3 <|>
 infixl 4 <*>, <*, *>, <**>
 
@@ -145,6 +149,16 @@ instance Applicative IO where
         pure = return
         (<*>) = ap
 
+#ifdef __GLASGOW_HASKELL__
+instance Applicative STM where
+    pure = return
+    (<*>) = ap
+
+instance Alternative STM where
+    empty = retry
+    (<|>) = orElse
+#endif
+
 instance Applicative ((->) a) where
         pure = const
         (<*>) f g x = f x (g x)
@@ -153,6 +167,11 @@ instance Monoid a => Applicative ((,) a) where
         pure x = (mempty, x)
         (u, f) <*> (v, x) = (u `mappend` v, f x)
 
+instance Applicative (Either e) where
+        pure          = Right
+        Left  e <*> _ = Left e
+        Right f <*> r = fmap f r
+
 -- new instances
 
 newtype Const a b = Const { getConst :: a }