{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-inline-rule-shadowing -Wno-orphans #-}
module Control.Arrow.Extended
( module Control.Arrow,
module Control.Arrow.Trans,
(>->),
(<-<),
dup,
bothA,
orA,
foldlA',
traverseA_,
traverseA,
onNothingA,
ArrowKleisli (..),
bindA,
)
where
import Control.Arrow
import Control.Arrow.Trans
import Control.Category
import Control.Monad
import Data.Foldable
import Prelude hiding (id, (.))
infixl 1 >->
infixr 1 <-<
(>->) :: (Arrow arr) => arr (e, s) a -> arr (e, (a, s)) b -> arr (e, s) b
arr (e, s) a
f >-> :: arr (e, s) a -> arr (e, (a, s)) b -> arr (e, s) b
>-> arr (e, (a, s)) b
g = proc (e
e, s
s) -> do
a
x <- arr (e, s) a
f -< (e
e, s
s)
arr (e, (a, s)) b
g -< (e
e, (a
x, s
s))
{-# INLINE (>->) #-}
(<-<) :: (Arrow arr) => arr (e, (a, s)) b -> arr (e, s) a -> arr (e, s) b
<-< :: arr (e, (a, s)) b -> arr (e, s) a -> arr (e, s) b
(<-<) = (arr (e, s) a -> arr (e, (a, s)) b -> arr (e, s) b)
-> arr (e, (a, s)) b -> arr (e, s) a -> arr (e, s) b
forall a b c. (a -> b -> c) -> b -> a -> c
flip arr (e, s) a -> arr (e, (a, s)) b -> arr (e, s) b
forall (arr :: * -> * -> *) e s a b.
Arrow arr =>
arr (e, s) a -> arr (e, (a, s)) b -> arr (e, s) b
(>->)
{-# INLINE (<-<) #-}
dup :: (Arrow arr) => arr a (a, a)
dup :: arr a (a, a)
dup = (a -> (a, a)) -> arr a (a, a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr \a
x -> (a
x, a
x)
{-# INLINE dup #-}
bothA :: (Arrow arr) => arr a b -> arr (a, a) (b, b)
bothA :: arr a b -> arr (a, a) (b, b)
bothA arr a b
f = arr a b
f arr a b -> arr a b -> arr (a, a) (b, b)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** arr a b
f
{-# INLINE bothA #-}
orA :: (ArrowChoice arr) => arr a Bool -> arr b Bool -> arr (a, b) Bool
orA :: arr a Bool -> arr b Bool -> arr (a, b) Bool
orA arr a Bool
f arr b Bool
g = proc (a
a, b
b) -> do
Bool
c <- arr a Bool
f -< a
a
if Bool
c then arr Bool Bool
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Bool
True else arr b Bool
g -< b
b
{-# INLINEABLE orA #-}
{-# RULES "orA/arr" forall f g. arr f `orA` arr g = arr (f `orA` g) #-}
foldlA' :: (ArrowChoice arr, Foldable t) => arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
foldlA' :: arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
foldlA' arr (e, (b, (a, s))) b
f = ((e, (b, (t a, s))) -> (e, (b, ([a], s))))
-> arr (e, (b, (t a, s))) (e, (b, ([a], s)))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(e
e, (b
v, (t a
xs, s
s))) -> (e
e, (b
v, (t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs, s
s)))) arr (e, (b, (t a, s))) (e, (b, ([a], s)))
-> arr (e, (b, ([a], s))) b -> arr (e, (b, (t a, s))) b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> arr (e, (b, ([a], s))) b
go
where
go :: arr (e, (b, ([a], s))) b
go = arr (e, (b, ([a], s))) (Either b ((e, (b, (a, s))), (e, ([a], s))))
forall a a a b.
arr (a, (a, ([a], b))) (Either a ((a, (a, (a, b))), (a, ([a], b))))
uncons arr (e, (b, ([a], s))) (Either b ((e, (b, (a, s))), (e, ([a], s))))
-> arr (Either b ((e, (b, (a, s))), (e, ([a], s)))) b
-> arr (e, (b, ([a], s))) b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (arr b b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id arr b b
-> arr ((e, (b, (a, s))), (e, ([a], s))) b
-> arr (Either b ((e, (b, (a, s))), (e, ([a], s)))) b
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| arr ((e, (b, (a, s))), (e, ([a], s))) b
step)
uncons :: arr (a, (a, ([a], b))) (Either a ((a, (a, (a, b))), (a, ([a], b))))
uncons = ((a, (a, ([a], b))) -> Either a ((a, (a, (a, b))), (a, ([a], b))))
-> arr
(a, (a, ([a], b))) (Either a ((a, (a, (a, b))), (a, ([a], b))))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr \(a
e, (a
v, ([a]
xs, b
s))) -> case [a]
xs of
[] -> a -> Either a ((a, (a, (a, b))), (a, ([a], b)))
forall a b. a -> Either a b
Left a
v
a
x : [a]
xs' -> ((a, (a, (a, b))), (a, ([a], b)))
-> Either a ((a, (a, (a, b))), (a, ([a], b)))
forall a b. b -> Either a b
Right ((a
e, (a
v, (a
x, b
s))), (a
e, ([a]
xs', b
s)))
step :: arr ((e, (b, (a, s))), (e, ([a], s))) b
step = arr (e, (b, (a, s))) b
-> arr ((e, (b, (a, s))), (e, ([a], s))) (b, (e, ([a], s)))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first arr (e, (b, (a, s))) b
f arr ((e, (b, (a, s))), (e, ([a], s))) (b, (e, ([a], s)))
-> arr (b, (e, ([a], s))) b
-> arr ((e, (b, (a, s))), (e, ([a], s))) b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((b, (e, ([a], s))) -> (e, (b, ([a], s))))
-> arr (b, (e, ([a], s))) (e, (b, ([a], s)))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(!b
v, (e
e, ([a]
xs, s
s))) -> (e
e, (b
v, ([a]
xs, s
s)))) arr (b, (e, ([a], s))) (e, (b, ([a], s)))
-> arr (e, (b, ([a], s))) b -> arr (b, (e, ([a], s))) b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> arr (e, (b, ([a], s))) b
go
{-# INLINEABLE foldlA' #-}
traverseA_ :: (ArrowChoice arr, Foldable t) => arr (e, (a, s)) b -> arr (e, (t a, s)) ()
traverseA_ :: arr (e, (a, s)) b -> arr (e, (t a, s)) ()
traverseA_ arr (e, (a, s)) b
f = proc (e
e, (t a
xs, s
s)) ->
(| forall a. arr (a, ((), (a, ()))) () -> arr (a, ((), (t a, ()))) ()
forall (arr :: * -> * -> *) (t :: * -> *) e b a s.
(ArrowChoice arr, Foldable t) =>
arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
foldlA' (\() a
x -> do (e
e, (a
x, s
s)) >- arr (e, (a, s)) b
f; () >- arr () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA) |) () t a
xs
{-# INLINEABLE traverseA_ #-}
data Traversal a r b
= Done b
| Yield a !(r -> Traversal a r b)
instance Functor (Traversal a r) where
fmap :: (a -> b) -> Traversal a r a -> Traversal a r b
fmap a -> b
f = \case
Done a
x -> b -> Traversal a r b
forall a r b. b -> Traversal a r b
Done (a -> b
f a
x)
Yield a
v r -> Traversal a r a
k -> a -> (r -> Traversal a r b) -> Traversal a r b
forall a r b. a -> (r -> Traversal a r b) -> Traversal a r b
Yield a
v ((a -> b) -> Traversal a r a -> Traversal a r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Traversal a r a -> Traversal a r b)
-> (r -> Traversal a r a) -> r -> Traversal a r b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. r -> Traversal a r a
k)
instance Applicative (Traversal a r) where
pure :: a -> Traversal a r a
pure = a -> Traversal a r a
forall a r b. b -> Traversal a r b
Done
Traversal a r (a -> b)
tf <*> :: Traversal a r (a -> b) -> Traversal a r a -> Traversal a r b
<*> Traversal a r a
tx = case Traversal a r (a -> b)
tf of
Done a -> b
f -> (a -> b) -> Traversal a r a -> Traversal a r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Traversal a r a
tx
Yield a
v r -> Traversal a r (a -> b)
k -> a -> (r -> Traversal a r b) -> Traversal a r b
forall a r b. a -> (r -> Traversal a r b) -> Traversal a r b
Yield a
v ((Traversal a r (a -> b) -> Traversal a r a -> Traversal a r b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Traversal a r a
tx) (Traversal a r (a -> b) -> Traversal a r b)
-> (r -> Traversal a r (a -> b)) -> r -> Traversal a r b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. r -> Traversal a r (a -> b)
k)
traversal :: (Traversable t) => t a -> Traversal a b (t b)
traversal :: t a -> Traversal a b (t b)
traversal = (a -> Traversal a b b) -> t a -> Traversal a b (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (a -> (b -> Traversal a b b) -> Traversal a b b
forall a r b. a -> (r -> Traversal a r b) -> Traversal a r b
`Yield` b -> Traversal a b b
forall a r b. b -> Traversal a r b
Done)
traverseA :: (ArrowChoice arr, Traversable t) => arr (e, (a, s)) b -> arr (e, (t a, s)) (t b)
traverseA :: arr (e, (a, s)) b -> arr (e, (t a, s)) (t b)
traverseA arr (e, (a, s)) b
f = arr (t a, s) (Traversal a b (t b), s)
-> arr (e, (t a, s)) (e, (Traversal a b (t b), s))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (arr (t a) (Traversal a b (t b))
-> arr (t a, s) (Traversal a b (t b), s)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (arr (t a) (Traversal a b (t b))
-> arr (t a, s) (Traversal a b (t b), s))
-> arr (t a) (Traversal a b (t b))
-> arr (t a, s) (Traversal a b (t b), s)
forall a b. (a -> b) -> a -> b
$ (t a -> Traversal a b (t b)) -> arr (t a) (Traversal a b (t b))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr t a -> Traversal a b (t b)
forall (t :: * -> *) a b.
Traversable t =>
t a -> Traversal a b (t b)
traversal) arr (e, (t a, s)) (e, (Traversal a b (t b), s))
-> arr (e, (Traversal a b (t b), s)) (t b)
-> arr (e, (t a, s)) (t b)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> arr (e, (Traversal a b (t b), s)) (t b)
go
where
go :: arr (e, (Traversal a b (t b), s)) (t b)
go = proc (e
e, (Traversal a b (t b)
as, s
s)) -> case Traversal a b (t b)
as of
Done t b
bs -> arr (t b) (t b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< t b
bs
Yield a
a b -> Traversal a b (t b)
k -> do
b
b <- arr (e, (a, s)) b
f -< (e
e, (a
a, s
s))
arr (e, (Traversal a b (t b), s)) (t b)
go -< (e
e, (b -> Traversal a b (t b)
k b
b, s
s))
{-# NOINLINE [1] traverseA #-}
traverseA_Maybe :: (ArrowChoice arr) => arr (e, (a, s)) b -> arr (e, (Maybe a, s)) (Maybe b)
traverseA_Maybe :: arr (e, (a, s)) b -> arr (e, (Maybe a, s)) (Maybe b)
traverseA_Maybe arr (e, (a, s)) b
f = proc (e
e, (Maybe a
v, s
s)) -> case Maybe a
v of
Just a
a -> (b -> Maybe b) -> arr b (Maybe b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> Maybe b
forall a. a -> Maybe a
Just arr b (Maybe b) -> arr (e, (a, s)) b -> arr (e, (a, s)) (Maybe b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (e, (a, s)) b
f -< (e
e, (a
a, s
s))
Maybe a
Nothing -> arr (Maybe b) (Maybe b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Maybe b
forall a. Maybe a
Nothing
{-# INLINEABLE traverseA_Maybe #-}
{-# RULES "traverseA @Maybe" traverseA = traverseA_Maybe #-}
onNothingA :: (ArrowChoice arr) => arr (e, s) a -> arr (e, (Maybe a, s)) a
onNothingA :: arr (e, s) a -> arr (e, (Maybe a, s)) a
onNothingA arr (e, s) a
f = proc (e
e, (Maybe a
v, s
s)) -> case Maybe a
v of
Just a
a -> arr a a
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< a
a
Maybe a
Nothing -> arr (e, s) a
f -< (e
e, s
s)
{-# INLINEABLE onNothingA #-}
#ifndef __HLINT__
{-# RULES
"arr/arr/R" forall f g h. arr f . (arr g . h) = arr (f . g) . h
"&&&/id" forall f. f &&& id = first f . dup
"id/&&&" forall f. id &&& f = second f . dup
"&&&/arr" forall f g. f &&& arr g = first f . arr (id &&& g)
"arr/&&&" forall f g. arr f &&& g = second g . arr (f &&& id)
"|||/id" forall f. f ||| id = arr (id ||| id) . left f
"id/|||" forall f. id ||| f = arr (id ||| id) . right f
"|||/arr" forall f g. f ||| arr g = arr (id ||| g) . left f
"arr/|||" forall f g. arr f ||| g = arr (f ||| id) . right g
#-}
class (Monad m, Arrow arr) => ArrowKleisli m arr | arr -> m where
arrM :: (a -> m b) -> arr a b
{-# RULES -- see Note [Arrow rewrite rules]
"arrM/pure" arrM pure = id
"arrM/pure/f" forall f. arrM (pure . f) = arr f
"arr/arrM" forall f g. arr f . arrM g = arrM (fmap f . g)
"arrM/arr" forall f g. arrM f . arr g = arrM (f . g)
"arrM/arrM" forall f g. arrM f . arrM g = arrM (f <=< g)
"arr/arrM/R" forall f g h. arr f . (arrM g . h) = arrM (fmap f . g) . h
"arrM/arr/R" forall f g h. arrM f . (arr g . h) = arrM (f . g) . h
"arrM/arrM/R" forall f g h. arrM f . (arrM g . h) = arrM (f <=< g) . h
"first/arrM" forall f. first (arrM f) = arrM (runKleisli (first (Kleisli f)))
"second/arrM" forall f. second (arrM f) = arrM (runKleisli (second (Kleisli f)))
"left/arrM" forall f. left (arrM f) = arrM (runKleisli (left (Kleisli f)))
"right/arrM" forall f. right (arrM f) = arrM (runKleisli (right (Kleisli f)))
"***/arrM" forall f g. arrM f *** arrM g = arrM (runKleisli (Kleisli f *** Kleisli g))
"&&&/arrM" forall f g. arrM f &&& arrM g = arrM (runKleisli (Kleisli f &&& Kleisli g))
"+++/arrM" forall f g. arrM f +++ arrM g = arrM (runKleisli (Kleisli f +++ Kleisli g))
"|||/arrM" forall f g. arrM f ||| arrM g = arrM (runKleisli (Kleisli f ||| Kleisli g))
#-}
#endif
bindA :: (ArrowKleisli m arr) => arr (m a) a
bindA :: arr (m a) a
bindA = (m a -> m a) -> arr (m a) a
forall (m :: * -> *) (arr :: * -> * -> *) a b.
ArrowKleisli m arr =>
(a -> m b) -> arr a b
arrM m a -> m a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE bindA #-}
instance (Monad m) => ArrowKleisli m (Kleisli m) where
arrM :: (a -> m b) -> Kleisli m a b
arrM = (a -> m b) -> Kleisli m a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli
instance (ArrowKleisli m arr, ArrowChoice arr) => ArrowKleisli m (ErrorA e arr) where
arrM :: (a -> m b) -> ErrorA e arr a b
arrM = arr a b -> ErrorA e arr a b
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA (arr a b -> ErrorA e arr a b)
-> ((a -> m b) -> arr a b) -> (a -> m b) -> ErrorA e arr a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> m b) -> arr a b
forall (m :: * -> *) (arr :: * -> * -> *) a b.
ArrowKleisli m arr =>
(a -> m b) -> arr a b
arrM
{-# INLINE arrM #-}
instance (ArrowKleisli m arr) => ArrowKleisli m (ReaderA r arr) where
arrM :: (a -> m b) -> ReaderA r arr a b
arrM = arr a b -> ReaderA r arr a b
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA (arr a b -> ReaderA r arr a b)
-> ((a -> m b) -> arr a b) -> (a -> m b) -> ReaderA r arr a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> m b) -> arr a b
forall (m :: * -> *) (arr :: * -> * -> *) a b.
ArrowKleisli m arr =>
(a -> m b) -> arr a b
arrM
{-# INLINE arrM #-}
instance (ArrowKleisli m arr) => ArrowKleisli m (WriterA w arr) where
arrM :: (a -> m b) -> WriterA w arr a b
arrM = arr a b -> WriterA w arr a b
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA (arr a b -> WriterA w arr a b)
-> ((a -> m b) -> arr a b) -> (a -> m b) -> WriterA w arr a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> m b) -> arr a b
forall (m :: * -> *) (arr :: * -> * -> *) a b.
ArrowKleisli m arr =>
(a -> m b) -> arr a b
arrM
{-# INLINE arrM #-}