module Control.Arrow.ListArrow
( LA(..)
, fromLA
)
where
import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
import Control.Arrow.ArrowNF
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowNavigatableTree
import Control.DeepSeq
import Data.List ( partition )
newtype LA a b = LA { forall a b. LA a b -> a -> [b]
runLA :: a -> [b] }
instance Category LA where
id :: forall a. LA a a
id = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ (forall a. a -> [a] -> [a]
:[])
{-# INLINE id #-}
LA b -> [c]
g . :: forall b c a. LA b c -> LA a b -> LA a c
. LA a -> [b]
f = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap b -> [c]
g forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> [b]
f
{-# INLINE (.) #-}
instance Arrow LA where
arr :: forall b c. (b -> c) -> LA b c
arr b -> c
f = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ b
x -> [b -> c
f b
x]
{-# INLINE arr #-}
first :: forall b c d. LA b c -> LA (b, d) (c, d)
first (LA b -> [c]
f) = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ ~(b
x1, d
x2) -> [ (c
y1, d
x2) | c
y1 <- b -> [c]
f b
x1 ]
second :: forall b c d. LA b c -> LA (d, b) (d, c)
second (LA b -> [c]
g) = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ ~(d
x1, b
x2) -> [ (d
x1, c
y2) | c
y2 <- b -> [c]
g b
x2 ]
LA b -> [c]
f *** :: forall b c b' c'. LA b c -> LA b' c' -> LA (b, b') (c, c')
*** LA b' -> [c']
g = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ ~(b
x1, b'
x2) -> [ (c
y1, c'
y2) | c
y1 <- b -> [c]
f b
x1, c'
y2 <- b' -> [c']
g b'
x2]
LA b -> [c]
f &&& :: forall b c c'. LA b c -> LA b c' -> LA b (c, c')
&&& LA b -> [c']
g = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ b
x -> [ (c
y1, c'
y2) | c
y1 <- b -> [c]
f b
x , c'
y2 <- b -> [c']
g b
x ]
instance ArrowZero LA where
zeroArrow :: forall b c. LA b c
zeroArrow = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const []
{-# INLINE zeroArrow #-}
instance ArrowPlus LA where
LA b -> [c]
f <+> :: forall b c. LA b c -> LA b c -> LA b c
<+> LA b -> [c]
g = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ b
x -> b -> [c]
f b
x forall a. [a] -> [a] -> [a]
++ b -> [c]
g b
x
{-# INLINE (<+>) #-}
instance ArrowChoice LA where
left :: forall b c d. LA b c -> LA (Either b d) (Either c d)
left (LA b -> [c]
f) = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> [c]
f) ((forall a. a -> [a] -> [a]
:[]) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. b -> Either a b
Right)
right :: forall b c d. LA b c -> LA (Either d b) (Either d c)
right (LA b -> [c]
f) = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((forall a. a -> [a] -> [a]
:[]) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> Either a b
Left) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> [c]
f)
LA b -> [c]
f +++ :: forall b c b' c'.
LA b c -> LA b' c' -> LA (Either b b') (Either c c')
+++ LA b' -> [c']
g = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> [c]
f) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b' -> [c']
g)
LA b -> [d]
f ||| :: forall b d c. LA b d -> LA c d -> LA (Either b c) d
||| LA c -> [d]
g = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> [d]
f c -> [d]
g
instance ArrowApply LA where
app :: forall b c. LA (LA b c, b) c
app = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ (LA b -> [c]
f, b
x) -> b -> [c]
f b
x
{-# INLINE app #-}
instance ArrowList LA where
arrL :: forall a b. (a -> [b]) -> LA a b
arrL = forall a b. (a -> [b]) -> LA a b
LA
{-# INLINE arrL #-}
arr2A :: forall b c d. (b -> LA c d) -> LA (b, c) d
arr2A b -> LA c d
f = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ ~(b
x, c
y) -> forall a b. LA a b -> a -> [b]
runLA (b -> LA c d
f b
x) c
y
{-# INLINE arr2A #-}
isA :: forall b. (b -> Bool) -> LA b b
isA b -> Bool
p = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ b
x -> if b -> Bool
p b
x then [b
x] else []
{-# INLINE isA #-}
LA b -> [c]
f >>. :: forall b c d. LA b c -> ([c] -> [d]) -> LA b d
>>. [c] -> [d]
g = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ [c] -> [d]
g forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> [c]
f
{-# INLINE (>>.) #-}
withDefault :: forall b c. LA b c -> c -> LA b c
withDefault LA b c
a c
d = LA b c
a forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. \ [c]
x -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
x then [c
d] else [c]
x
instance ArrowIf LA where
ifA :: forall b c d. LA b c -> LA b d -> LA b d -> LA b d
ifA (LA b -> [c]
p) LA b d
t LA b d
e = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ b
x -> forall a b. LA a b -> a -> [b]
runLA ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (b -> [c]
p b
x)
then LA b d
e
else LA b d
t
) b
x
{-# INLINE ifA #-}
(LA b -> [c]
f) orElse :: forall b c. LA b c -> LA b c -> LA b c
`orElse` (LA b -> [c]
g)
= forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ b
x -> ( let
res :: [c]
res = b -> [c]
f b
x
in
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
res
then b -> [c]
g b
x
else [c]
res
)
{-# INLINE orElse #-}
spanA :: forall b. LA b b -> LA [b] ([b], [b])
spanA LA b b
p = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ (forall a. a -> [a] -> [a]
:[]) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. LA a b -> a -> [b]
runLA LA b b
p)
partitionA :: forall b. LA b b -> LA [b] ([b], [b])
partitionA LA b b
p = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ (forall a. a -> [a] -> [a]
:[]) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. LA a b -> a -> [b]
runLA LA b b
p)
instance ArrowTree LA
instance ArrowNavigatableTree LA
instance ArrowNF LA where
rnfA :: forall c b. NFData c => LA b c -> LA b c
rnfA (LA b -> [c]
f) = forall a b. (a -> [b]) -> LA a b
LA forall a b. (a -> b) -> a -> b
$ \ b
x -> let res :: [c]
res = b -> [c]
f b
x
in
[c]
res forall a b. NFData a => a -> b -> b
`deepseq` [c]
res
instance ArrowWNF LA
fromLA :: ArrowList a => LA b c -> a b c
fromLA :: forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA LA b c
f = forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (forall a b. LA a b -> a -> [b]
runLA LA b c
f)
{-# INLINE fromLA #-}