Allow arr ∧ (first ∨ (***)) as minimal definition of Arrow instance
[ghc.git] / libraries / base / Control / Arrow.hs
index 73dfe3d..1cc6062 100644 (file)
@@ -1,4 +1,9 @@
 {-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
+    -- The RULES for the methods of class Arrow may never fire
+    -- e.g. compose/arr;  see Trac #10528
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Arrow
 -- Portability :  portable
 --
 -- Basic arrow definitions, based on
+--
 --  * /Generalising Monads to Arrows/, by John Hughes,
 --    /Science of Computer Programming/ 37, pp67-111, May 2000.
+--
 -- plus a couple of definitions ('returnA' and 'loop') from
+--
 --  * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,
 --    Firenze, Italy, pp229-240.
+--
 -- These papers and more information on arrows can be found at
 -- <http://www.haskell.org/arrows/>.
 
@@ -37,11 +46,11 @@ module Control.Arrow (
     ArrowLoop(..)
     ) where
 
-import Prelude hiding (id,(.))
-
-import Control.Monad
+import Data.Tuple ( fst, snd, uncurry )
+import Data.Either
 import Control.Monad.Fix
 import Control.Category
+import GHC.Base hiding ( (.), id )
 
 infixr 5 <+>
 infixr 3 ***
@@ -53,7 +62,7 @@ infixr 1 ^<<, <<^
 
 -- | The basic arrow class.
 --
--- Minimal complete definition: 'arr' and 'first', satisfying the laws
+-- Instances should satisfy the following laws:
 --
 --  * @'arr' id = 'id'@
 --
@@ -84,16 +93,14 @@ class Category a => Arrow a where
     -- | Send the first component of the input through the argument
     --   arrow, and copy the rest unchanged to the output.
     first :: a b c -> a (b,d) (c,d)
+    first = (*** id)
 
     -- | A mirror image of 'first'.
     --
     --   The default definition may be overridden with a more efficient
     --   version if desired.
     second :: a b c -> a (d,b) (d,c)
-    second f = arr swap >>> first f >>> arr swap
-      where
-        swap :: (x,y) -> (y,x)
-        swap ~(x,y) = (y,x)
+    second = (id ***)
 
     -- | Split the input between the two argument arrows and combine
     --   their output.  Note that this is in general not a functor.
@@ -101,7 +108,8 @@ class Category a => Arrow a where
     --   The default definition may be overridden with a more efficient
     --   version if desired.
     (***) :: a b c -> a b' c' -> a (b,b') (c,c')
-    f *** g = first f >>> second g
+    f *** g = first f >>> arr swap >>> first g >>> arr swap
+      where swap ~(x,y) = (y,x)
 
     -- | Fanout: send the input to both argument arrows and combine
     --   their output.
@@ -132,8 +140,6 @@ class Category a => Arrow a where
 
 instance Arrow (->) where
     arr f = f
-    first f = f *** id
-    second f = id *** f
 --  (f *** g) ~(x,y) = (f x, g y)
 --  sorry, although the above defn is fully H'98, nhc98 can't parse it.
     (***) f g ~(x,y) = (f x, g y)
@@ -186,13 +192,14 @@ instance MonadPlus m => ArrowPlus (Kleisli m) where
 
 -- | Choice, for arrows that support it.  This class underlies the
 -- @if@ and @case@ constructs in arrow notation.
--- Minimal complete definition: 'left', satisfying the laws
+--
+-- Instances should satisfy the following laws:
 --
 --  * @'left' ('arr' f) = 'arr' ('left' f)@
 --
 --  * @'left' (f >>> g) = 'left' f >>> 'left' g@
 --
---  * @'left' f >>> 'arr' 'Left' = 'arr' 'Left' >>> f@
+--  * @f >>> 'arr' 'Left' = 'arr' 'Left' >>> 'left' f@
 --
 --  * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@
 --
@@ -299,11 +306,18 @@ newtype ArrowMonad a b = ArrowMonad (a () b)
 instance Arrow a => Functor (ArrowMonad a) where
     fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f
 
+instance Arrow a => Applicative (ArrowMonad a) where
+   pure x = ArrowMonad (arr (const x))
+   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
+
 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 ArrowPlus a => Alternative (ArrowMonad a) where
+   empty = ArrowMonad zeroArrow
+   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
+
 instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where
    mzero = ArrowMonad zeroArrow
    ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y)