{-# LANGUAGE Trustworthy #-}{-# LANGUAGE NoImplicitPrelude #-}{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}-- The RULES for the methods of class Arrow may never fire-- e.g. compose/arr; see Trac #10528------------------------------------------------------------------------------- |-- Module : Control.Arrow-- Copyright : (c) Ross Paterson 2002-- License : BSD-style (see the LICENSE file in the distribution)---- Maintainer : libraries@haskell.org-- Stability : provisional-- 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/>.moduleControl.Arrow(-- * ArrowsArrow (..),Kleisli (..),-- ** Derived combinatorsreturnA ,(^>> ),(>>^ ),(>>> ),(<<< ),-- reexported-- ** Right-to-left variants(<<^ ),(^<< ),-- * Monoid operationsArrowZero (..),ArrowPlus (..),-- * ConditionalsArrowChoice (..),-- * Arrow applicationArrowApply (..),ArrowMonad (..),leftApp ,-- * FeedbackArrowLoop (..))whereimportData.Tuple (fst ,snd ,uncurry )importData.Either importControl.Monad.Fix importControl.Category importGHC.Base hiding((. ),id )infixr5<+>infixr3***infixr3&&&infixr2+++infixr2|||infixr1^>>,>>^infixr1^<<,<<^-- | The basic arrow class.---- Instances should satisfy the following laws:---- * @'arr' id = 'id'@---- * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@---- * @'first' ('arr' f) = 'arr' ('first' f)@---- * @'first' (f >>> g) = 'first' f >>> 'first' g@---- * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@---- * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@---- * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@---- where---- > assoc ((a,b),c) = (a,(b,c))---- The other combinators have sensible default definitions,-- which may be overridden for efficiency.classCategory a =>Arrow a where{-# MINIMAL arr, (first | (***)) #-}-- | Lift a function to an arrow.arr::(b ->c )->a b c -- | 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 =(id *** )-- | Split the input between the two argument arrows and combine-- their output. Note that this is in general not a functor.---- 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 >>> arr swap >>> first g >>> arr swap whereswap ~(x ,y )=(y ,x )-- | Fanout: send the input to both argument arrows and combine-- their output.---- The default definition may be overridden with a more efficient-- version if desired.(&&&)::a b c ->a b c' ->a b (c ,c' )f &&& g =arr (\b ->(b ,b ))>>> f *** g {-# RULES
"compose/arr" forall f g .
 (arr f) . (arr g) = arr (f . g)
"first/arr" forall f .
 first (arr f) = arr (first f)
"second/arr" forall f .
 second (arr f) = arr (second f)
"product/arr" forall f g .
 arr f *** arr g = arr (f *** g)
"fanout/arr" forall f g .
 arr f &&& arr g = arr (f &&& g)
"compose/first" forall f g .
 (first f) . (first g) = first (f . g)
"compose/second" forall f g .
 (second f) . (second g) = second (f . g)
 #-}-- Ordinary functions are arrows.-- | @since 2.01instanceArrow (->)wherearr f =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 )-- | Kleisli arrows of a monad.newtypeKleisli m a b =Kleisli {runKleisli ::a ->m b }-- | @since 3.0instanceMonad m =>Category (Kleisli m )whereid =Kleisli return (Kleisli f ). (Kleisli g )=Kleisli (\b ->g b >>= f )-- | @since 2.01instanceMonad m =>Arrow (Kleisli m )wherearr f =Kleisli (return . f )first (Kleisli f )=Kleisli (\~(b ,d )->f b >>= \c ->return (c ,d ))second (Kleisli f )=Kleisli (\~(d ,b )->f b >>= \c ->return (d ,c ))-- | The identity arrow, which plays the role of 'return' in arrow notation.returnA::Arrow a =>a b b returnA =arr id -- | Precomposition with a pure function.(^>>)::Arrow a =>(b ->c )->a c d ->a b d f ^>> a =arr f >>> a -- | Postcomposition with a pure function.(>>^)::Arrow a =>a b c ->(c ->d )->a b d a >>^ f =a >>> arr f -- | Precomposition with a pure function (right-to-left variant).(<<^)::Arrow a =>a c d ->(b ->c )->a b d a <<^ f =a <<< arr f -- | Postcomposition with a pure function (right-to-left variant).(^<<)::Arrow a =>(c ->d )->a b c ->a b d f ^<< a =arr f <<< a classArrow a =>ArrowZero a wherezeroArrow::a b c -- | @since 2.01instanceMonadPlus m =>ArrowZero (Kleisli m )wherezeroArrow =Kleisli (\_->mzero )-- | A monoid on arrows.classArrowZero a =>ArrowPlus a where-- | An associative operation with identity 'zeroArrow'.(<+>)::a b c ->a b c ->a b c -- | @since 2.01instanceMonadPlus m =>ArrowPlus (Kleisli m )whereKleisli f <+> Kleisli g =Kleisli (\x ->f x `mplus `g x )-- | Choice, for arrows that support it. This class underlies the-- @if@ and @case@ constructs in arrow notation.---- Instances should satisfy the following laws:---- * @'left' ('arr' f) = 'arr' ('left' f)@---- * @'left' (f >>> g) = 'left' f >>> 'left' g@---- * @f >>> 'arr' 'Left' = 'arr' 'Left' >>> 'left' f@---- * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@---- * @'left' ('left' f) >>> 'arr' 'assocsum' = 'arr' 'assocsum' >>> 'left' f@---- where---- > assocsum (Left (Left x)) = Left x-- > assocsum (Left (Right y)) = Right (Left y)-- > assocsum (Right z) = Right (Right z)---- The other combinators have sensible default definitions, which may-- be overridden for efficiency.classArrow a =>ArrowChoice a where{-# MINIMAL (left | (+++)) #-}-- | Feed marked inputs through the argument arrow, passing the-- rest through unchanged to the output.left::a b c ->a (Either b d )(Either c d )left =(+++ id )-- | A mirror image of 'left'.---- The default definition may be overridden with a more efficient-- version if desired.right::a b c ->a (Either d b )(Either d c )right =(id +++ )-- | Split the input between the two argument arrows, retagging-- and merging their outputs.-- Note that this is in general not a functor.---- The default definition may be overridden with a more efficient-- version if desired.(+++)::a b c ->a b' c' ->a (Either b b' )(Either c c' )f +++ g =left f >>> arr mirror >>> left g >>> arr mirror wheremirror::Either x y ->Either y x mirror (Left x )=Right x mirror(Right y )=Left y -- | Fanin: Split the input between the two argument arrows and-- merge their outputs.---- The default definition may be overridden with a more efficient-- version if desired.(|||)::a b d ->a c d ->a (Either b c )d f ||| g =f +++ g >>> arr untag whereuntag (Left x )=x untag(Right y )=y {-# RULES
"left/arr" forall f .
 left (arr f) = arr (left f)
"right/arr" forall f .
 right (arr f) = arr (right f)
"sum/arr" forall f g .
 arr f +++ arr g = arr (f +++ g)
"fanin/arr" forall f g .
 arr f ||| arr g = arr (f ||| g)
"compose/left" forall f g .
 left f . left g = left (f . g)
"compose/right" forall f g .
 right f . right g = right (f . g)
 #-}-- | @since 2.01instanceArrowChoice (->)whereleft f =f +++ id right f =id +++ f f +++ g =(Left . f )||| (Right . g )(||| )=either -- | @since 2.01instanceMonad m =>ArrowChoice (Kleisli m )whereleft f =f +++ arr id right f =arr id +++ f f +++ g =(f >>> arr Left )||| (g >>> arr Right )Kleisli f ||| Kleisli g =Kleisli (either f g )-- | Some arrows allow application of arrow inputs to other inputs.-- Instances should satisfy the following laws:---- * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@---- * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@---- * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@---- Such arrows are equivalent to monads (see 'ArrowMonad').classArrow a =>ArrowApply a whereapp::a (a b c ,b )c -- | @since 2.01instanceArrowApply (->)whereapp (f ,x )=f x -- | @since 2.01instanceMonad m =>ArrowApply (Kleisli m )whereapp =Kleisli (\(Kleisli f ,x )->f x )-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise-- to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.newtypeArrowMonad a b =ArrowMonad (a ()b )-- | @since 4.6.0.0instanceArrow a =>Functor (ArrowMonad a )wherefmap f (ArrowMonad m )=ArrowMonad $ m >>> arr f -- | @since 4.6.0.0instanceArrow a =>Applicative (ArrowMonad a )wherepure x =ArrowMonad (arr (const x ))ArrowMonad f <*> ArrowMonad x =ArrowMonad (f &&& x >>> arr (uncurry id ))-- | @since 2.01instanceArrowApply a =>Monad (ArrowMonad a )whereArrowMonad m >>= f =ArrowMonad $ m >>> arr (\x ->letArrowMonad h =f x in(h ,()))>>> app -- | @since 4.6.0.0instanceArrowPlus a =>Alternative (ArrowMonad a )whereempty =ArrowMonad zeroArrow ArrowMonad x <|> ArrowMonad y =ArrowMonad (x <+> y )-- | @since 4.6.0.0instance(ArrowApply a ,ArrowPlus a )=>MonadPlus (ArrowMonad a )-- | Any instance of 'ArrowApply' can be made into an instance of-- 'ArrowChoice' by defining 'left' = 'leftApp'.leftApp::ArrowApply a =>a b c ->a (Either b d )(Either c d )leftApp f =arr ((\b ->(arr (\()->b )>>> f >>> arr Left ,()))||| (\d ->(arr (\()->d )>>> arr Right ,())))>>> app -- | The 'loop' operator expresses computations in which an output value-- is fed back as input, although the computation occurs only once.-- It underlies the @rec@ value recursion construct in arrow notation.-- 'loop' should satisfy the following laws:---- [/extension/]-- @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@---- [/left tightening/]-- @'loop' ('first' h >>> f) = h >>> 'loop' f@---- [/right tightening/]-- @'loop' (f >>> 'first' h) = 'loop' f >>> h@---- [/sliding/]-- @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@---- [/vanishing/]-- @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@---- [/superposing/]-- @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@---- where---- > assoc ((a,b),c) = (a,(b,c))-- > unassoc (a,(b,c)) = ((a,b),c)--classArrow a =>ArrowLoop a whereloop::a (b ,d )(c ,d )->a b c -- | @since 2.01instanceArrowLoop (->)whereloop f b =let(c ,d )=f (b ,d )inc -- | Beware that for many monads (those for which the '>>=' operation-- is strict) this instance will /not/ satisfy the right-tightening law-- required by the 'ArrowLoop' class.---- @since 2.01instanceMonadFix m =>ArrowLoop (Kleisli m )whereloop (Kleisli f )=Kleisli (liftM fst . mfix . f' )wheref' x y =f (x ,snd y )