(original) (raw)

{-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}

module Control.Arrow (

[Arrow](Control.Arrow.html#Arrow)(..), [Kleisli](Control.Arrow.html#Kleisli)(..),

[returnA](Control.Arrow.html#returnA),
([^>>](Control.Arrow.html#%5E%3E%3E)), ([>>^](Control.Arrow.html#%3E%3E%5E)),
([>>>](Control.Category.html#%3E%3E%3E)), ([<<<](Control.Category.html#%3C%3C%3C)), 

([<<^](Control.Arrow.html#%3C%3C%5E)), ([^<<](Control.Arrow.html#%5E%3C%3C)),

[ArrowZero](Control.Arrow.html#ArrowZero)(..), [ArrowPlus](Control.Arrow.html#ArrowPlus)(..),

[ArrowChoice](Control.Arrow.html#ArrowChoice)(..),

[ArrowApply](Control.Arrow.html#ArrowApply)(..), [ArrowMonad](Control.Arrow.html#ArrowMonad)(..), [leftApp](Control.Arrow.html#leftApp),

[ArrowLoop](Control.Arrow.html#ArrowLoop)(..)
) where

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 *** infixr 3 &&& infixr 2 +++ infixr 2 ||| infixr 1 ^>>, >>^ infixr 1 ^<<, <<^

class Category a => Arrow a where {-# MINIMAL arr, (first | (***)) #-}

[arr](Control.Arrow.html#arr) :: ([b](#local-6989586621679384659) -> [c](#local-6989586621679384660)) -> [a](#local-6989586621679384658) [b](#local-6989586621679384659) [c](#local-6989586621679384660)


[first](Control.Arrow.html#first) :: [a](#local-6989586621679384658) [b](#local-6989586621679384661) [c](#local-6989586621679384662) -> [a](#local-6989586621679384658) ([b](#local-6989586621679384661),[d](#local-6989586621679384663)) ([c](#local-6989586621679384662),[d](#local-6989586621679384663))
[first](Control.Arrow.html#first) = ([***](Control.Arrow.html#%2A%2A%2A) [id](Control.Category.html#id))


[second](Control.Arrow.html#second) :: [a](#local-6989586621679384658) [b](#local-6989586621679384664) [c](#local-6989586621679384665) -> [a](#local-6989586621679384658) ([d](#local-6989586621679384666),[b](#local-6989586621679384664)) ([d](#local-6989586621679384666),[c](#local-6989586621679384665))
[second](Control.Arrow.html#second) = ([id](Control.Category.html#id) [***](Control.Arrow.html#%2A%2A%2A))


([***](Control.Arrow.html#%2A%2A%2A)) :: [a](#local-6989586621679384658) [b](#local-6989586621679384667) [c](#local-6989586621679384668) -> [a](#local-6989586621679384658) [b'](#local-6989586621679384669) [c'](#local-6989586621679384670) -> [a](#local-6989586621679384658) ([b](#local-6989586621679384667),[b'](#local-6989586621679384669)) ([c](#local-6989586621679384668),[c'](#local-6989586621679384670))
[f](#local-6989586621679384674) [***](Control.Arrow.html#%2A%2A%2A) [g](#local-6989586621679384675) = [first](Control.Arrow.html#first) [f](#local-6989586621679384674) [>>>](Control.Category.html#%3E%3E%3E) [arr](Control.Arrow.html#arr) [swap](#local-6989586621679384676) [>>>](Control.Category.html#%3E%3E%3E) [first](Control.Arrow.html#first) [g](#local-6989586621679384675) [>>>](Control.Category.html#%3E%3E%3E) [arr](Control.Arrow.html#arr) [swap](#local-6989586621679384676)
  where [swap](#local-6989586621679384676) ~([x](#local-6989586621679384677),[y](#local-6989586621679384678)) = ([y](#local-6989586621679384678),[x](#local-6989586621679384677))


([&&&](Control.Arrow.html#%26%26%26)) :: [a](#local-6989586621679384658) [b](#local-6989586621679384671) [c](#local-6989586621679384672) -> [a](#local-6989586621679384658) [b](#local-6989586621679384671) [c'](#local-6989586621679384673) -> [a](#local-6989586621679384658) [b](#local-6989586621679384671) ([c](#local-6989586621679384672),[c'](#local-6989586621679384673))
[f](#local-6989586621679384679) [&&&](Control.Arrow.html#%26%26%26) [g](#local-6989586621679384680) = [arr](Control.Arrow.html#arr) (\[b](#local-6989586621679384681) -> ([b](#local-6989586621679384681),[b](#local-6989586621679384681))) [>>>](Control.Category.html#%3E%3E%3E) [f](#local-6989586621679384679) [***](Control.Arrow.html#%2A%2A%2A) [g](#local-6989586621679384680)

{-# 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) #-}

instance Arrow (->) where arr f = f

([***](Control.Arrow.html#%2A%2A%2A)) [f](#local-6989586621679384743) [g](#local-6989586621679384744) ~([x](#local-6989586621679384745),[y](#local-6989586621679384746)) = ([f](#local-6989586621679384743) [x](#local-6989586621679384745), [g](#local-6989586621679384744) [y](#local-6989586621679384746))

newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }

instance Monad m => Category (Kleisli m) where id = Kleisli return (Kleisli f) . (Kleisli g) = Kleisli ([b](#local-6989586621679384741) -> g b >>= f)

instance Monad m => Arrow (Kleisli m) where arr f = Kleisli (return . f) first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= [c](#local-6989586621679384733) -> return (c,d)) second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= [c](#local-6989586621679384737) -> return (d,c))

returnA :: Arrow a => a b b returnA = arr id

(^>>) :: Arrow a => (b -> c) -> a c d -> a b d f ^>> a = arr f >>> a

(>>^) :: Arrow a => a b c -> (c -> d) -> a b d a >>^ f = a >>> arr f

(<<^) :: Arrow a => a c d -> (b -> c) -> a b d a <<^ f = a <<< arr f

(^<<) :: Arrow a => (c -> d) -> a b c -> a b d f ^<< a = arr f <<< a

class Arrow a => ArrowZero a where zeroArrow :: a b c

instance MonadPlus m => ArrowZero (Kleisli m) where zeroArrow = Kleisli (_ -> mzero)

class ArrowZero a => ArrowPlus a where

([<+>](Control.Arrow.html#%3C%2B%3E)) :: [a](#local-6989586621679384649) [b](#local-6989586621679384650) [c](#local-6989586621679384651) -> [a](#local-6989586621679384649) [b](#local-6989586621679384650) [c](#local-6989586621679384651) -> [a](#local-6989586621679384649) [b](#local-6989586621679384650) [c](#local-6989586621679384651)

instance MonadPlus m => ArrowPlus (Kleisli m) where Kleisli f <+> Kleisli g = Kleisli ([x](#local-6989586621679384726) -> f x [mplus](GHC.Base.html#mplus) g x)

class Arrow a => ArrowChoice a where {-# MINIMAL (left | (+++)) #-}

[left](Control.Arrow.html#left) :: [a](#local-6989586621679384623) [b](#local-6989586621679384624) [c](#local-6989586621679384625) -> [a](#local-6989586621679384623) ([Either](Data.Either.html#Either) [b](#local-6989586621679384624) [d](#local-6989586621679384626)) ([Either](Data.Either.html#Either) [c](#local-6989586621679384625) [d](#local-6989586621679384626))
[left](Control.Arrow.html#left) = ([+++](Control.Arrow.html#%2B%2B%2B) [id](Control.Category.html#id))


[right](Control.Arrow.html#right) :: [a](#local-6989586621679384623) [b](#local-6989586621679384627) [c](#local-6989586621679384628) -> [a](#local-6989586621679384623) ([Either](Data.Either.html#Either) [d](#local-6989586621679384629) [b](#local-6989586621679384627)) ([Either](Data.Either.html#Either) [d](#local-6989586621679384629) [c](#local-6989586621679384628))
[right](Control.Arrow.html#right) = ([id](Control.Category.html#id) [+++](Control.Arrow.html#%2B%2B%2B))


([+++](Control.Arrow.html#%2B%2B%2B)) :: [a](#local-6989586621679384623) [b](#local-6989586621679384630) [c](#local-6989586621679384631) -> [a](#local-6989586621679384623) [b'](#local-6989586621679384632) [c'](#local-6989586621679384633) -> [a](#local-6989586621679384623) ([Either](Data.Either.html#Either) [b](#local-6989586621679384630) [b'](#local-6989586621679384632)) ([Either](Data.Either.html#Either) [c](#local-6989586621679384631) [c'](#local-6989586621679384633))
[f](#local-6989586621679384637) [+++](Control.Arrow.html#%2B%2B%2B) [g](#local-6989586621679384638) = [left](Control.Arrow.html#left) [f](#local-6989586621679384637) [>>>](Control.Category.html#%3E%3E%3E) [arr](Control.Arrow.html#arr) [mirror](#local-6989586621679384639) [>>>](Control.Category.html#%3E%3E%3E) [left](Control.Arrow.html#left) [g](#local-6989586621679384638) [>>>](Control.Category.html#%3E%3E%3E) [arr](Control.Arrow.html#arr) [mirror](#local-6989586621679384639)
  where
    mirror :: [Either](Data.Either.html#Either) [x](#local-6989586621679384640) [y](#local-6989586621679384641) -> [Either](Data.Either.html#Either) [y](#local-6989586621679384641) [x](#local-6989586621679384640)
    [mirror](#local-6989586621679384639) ([Left](Data.Either.html#Left) [x](#local-6989586621679384642)) = [Right](Data.Either.html#Right) [x](#local-6989586621679384642)
    mirror ([Right](Data.Either.html#Right) [y](#local-6989586621679384643)) = [Left](Data.Either.html#Left) [y](#local-6989586621679384643)


([|||](Control.Arrow.html#%7C%7C%7C)) :: [a](#local-6989586621679384623) [b](#local-6989586621679384634) [d](#local-6989586621679384635) -> [a](#local-6989586621679384623) [c](#local-6989586621679384636) [d](#local-6989586621679384635) -> [a](#local-6989586621679384623) ([Either](Data.Either.html#Either) [b](#local-6989586621679384634) [c](#local-6989586621679384636)) [d](#local-6989586621679384635)
[f](#local-6989586621679384644) [|||](Control.Arrow.html#%7C%7C%7C) [g](#local-6989586621679384645) = [f](#local-6989586621679384644) [+++](Control.Arrow.html#%2B%2B%2B) [g](#local-6989586621679384645) [>>>](Control.Category.html#%3E%3E%3E) [arr](Control.Arrow.html#arr) [untag](#local-6989586621679384646)
  where
    [untag](#local-6989586621679384646) ([Left](Data.Either.html#Left) [x](#local-6989586621679384647)) = [x](#local-6989586621679384647)
    untag ([Right](Data.Either.html#Right) [y](#local-6989586621679384648)) = [y](#local-6989586621679384648)

{-# 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) #-}

instance ArrowChoice (->) where left f = f +++ id right f = id +++ f f +++ g = (Left . f) ||| (Right . g) (|||) = either

instance Monad m => ArrowChoice (Kleisli m) where left 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)

class Arrow a => ArrowApply a where app :: a (a b c, b) c

instance ArrowApply (->) where app (f,x) = f x

instance Monad m => ArrowApply (Kleisli m) where app = Kleisli ((Kleisli f, x) -> f x)

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 ArrowMonad m >>= f = ArrowMonad $ m >>> arr ([x](#local-6989586621679384698) -> 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)

leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d) leftApp f = arr (([b](#local-6989586621679384778) -> (arr (() -> b) >>> f >>> arr Left, ())) ||| ([d](#local-6989586621679384779) -> (arr (() -> d) >>> arr Right, ()))) >>> app

class Arrow a => ArrowLoop a where loop :: a (b,d) (c,d) -> a b c

instance ArrowLoop (->) where loop f b = let (c,d) = f (b,d) in c

instance MonadFix m => ArrowLoop (Kleisli m) where loop (Kleisli f) = Kleisli (liftM fst . mfix . f') where f' x y = f (x, snd y)