-- ------------------------------------------------------------

{- |
   Module     : Control.Arrow.ListArrow
   Copyright  : Copyright (C) 2005 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   Implementation of pure list arrows

-}

-- ------------------------------------------------------------

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 )

-- ------------------------------------------------------------

-- | pure list arrow data type

newtype LA a b = LA { LA a b -> a -> [b]
runLA :: a -> [b] }

instance Category LA where
    id :: LA a a
id                  = (a -> [a]) -> LA a a
forall a b. (a -> [b]) -> LA a b
LA ((a -> [a]) -> LA a a) -> (a -> [a]) -> LA a a
forall a b. (a -> b) -> a -> b
$ (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])
    {-# INLINE id #-}
    LA b -> [c]
g . :: LA b c -> LA a b -> LA a c
. LA a -> [b]
f         = (a -> [c]) -> LA a c
forall a b. (a -> [b]) -> LA a b
LA ((a -> [c]) -> LA a c) -> (a -> [c]) -> LA a c
forall a b. (a -> b) -> a -> b
$ (b -> [c]) -> [b] -> [c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap b -> [c]
g ([b] -> [c]) -> (a -> [b]) -> a -> [c]
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 :: (b -> c) -> LA b c
arr b -> c
f               = (b -> [c]) -> LA b c
forall a b. (a -> [b]) -> LA a b
LA ((b -> [c]) -> LA b c) -> (b -> [c]) -> LA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> [b -> c
f b
x]
    {-# INLINE arr #-}
    first :: LA b c -> LA (b, d) (c, d)
first (LA b -> [c]
f)        = ((b, d) -> [(c, d)]) -> LA (b, d) (c, d)
forall a b. (a -> [b]) -> LA a b
LA (((b, d) -> [(c, d)]) -> LA (b, d) (c, d))
-> ((b, d) -> [(c, d)]) -> LA (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \ ~(b
x1, d
x2) -> [ (c
y1, d
x2) | c
y1 <- b -> [c]
f b
x1 ]

    -- just for efficiency

    second :: LA b c -> LA (d, b) (d, c)
second (LA b -> [c]
g)       = ((d, b) -> [(d, c)]) -> LA (d, b) (d, c)
forall a b. (a -> [b]) -> LA a b
LA (((d, b) -> [(d, c)]) -> LA (d, b) (d, c))
-> ((d, b) -> [(d, c)]) -> LA (d, b) (d, c)
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 *** :: LA b c -> LA b' c' -> LA (b, b') (c, c')
*** LA b' -> [c']
g       = ((b, b') -> [(c, c')]) -> LA (b, b') (c, c')
forall a b. (a -> [b]) -> LA a b
LA (((b, b') -> [(c, c')]) -> LA (b, b') (c, c'))
-> ((b, b') -> [(c, c')]) -> LA (b, b') (c, c')
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 &&& :: LA b c -> LA b c' -> LA b (c, c')
&&& LA b -> [c']
g       = (b -> [(c, c')]) -> LA b (c, c')
forall a b. (a -> [b]) -> LA a b
LA ((b -> [(c, c')]) -> LA b (c, c'))
-> (b -> [(c, c')]) -> LA b (c, c')
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 :: LA b c
zeroArrow           = (b -> [c]) -> LA b c
forall a b. (a -> [b]) -> LA a b
LA ((b -> [c]) -> LA b c) -> (b -> [c]) -> LA b c
forall a b. (a -> b) -> a -> b
$ [c] -> b -> [c]
forall a b. a -> b -> a
const []
    {-# INLINE zeroArrow #-}


instance ArrowPlus LA where
    LA b -> [c]
f <+> :: LA b c -> LA b c -> LA b c
<+> LA b -> [c]
g       = (b -> [c]) -> LA b c
forall a b. (a -> [b]) -> LA a b
LA ((b -> [c]) -> LA b c) -> (b -> [c]) -> LA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> b -> [c]
f b
x [c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
++ b -> [c]
g b
x
    {-# INLINE (<+>) #-}

instance ArrowChoice LA where
    left :: LA b c -> LA (Either b d) (Either c d)
left  (LA b -> [c]
f)        = (Either b d -> [Either c d]) -> LA (Either b d) (Either c d)
forall a b. (a -> [b]) -> LA a b
LA ((Either b d -> [Either c d]) -> LA (Either b d) (Either c d))
-> (Either b d -> [Either c d]) -> LA (Either b d) (Either c d)
forall a b. (a -> b) -> a -> b
$ (b -> [Either c d])
-> (d -> [Either c d]) -> Either b d -> [Either c d]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((c -> Either c d) -> [c] -> [Either c d]
forall a b. (a -> b) -> [a] -> [b]
map c -> Either c d
forall a b. a -> Either a b
Left ([c] -> [Either c d]) -> (b -> [c]) -> b -> [Either c d]
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) ((Either c d -> [Either c d] -> [Either c d]
forall a. a -> [a] -> [a]
:[]) (Either c d -> [Either c d])
-> (d -> Either c d) -> d -> [Either c d]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. d -> Either c d
forall a b. b -> Either a b
Right)
    right :: LA b c -> LA (Either d b) (Either d c)
right (LA b -> [c]
f)        = (Either d b -> [Either d c]) -> LA (Either d b) (Either d c)
forall a b. (a -> [b]) -> LA a b
LA ((Either d b -> [Either d c]) -> LA (Either d b) (Either d c))
-> (Either d b -> [Either d c]) -> LA (Either d b) (Either d c)
forall a b. (a -> b) -> a -> b
$ (d -> [Either d c])
-> (b -> [Either d c]) -> Either d b -> [Either d c]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Either d c -> [Either d c] -> [Either d c]
forall a. a -> [a] -> [a]
:[]) (Either d c -> [Either d c])
-> (d -> Either d c) -> d -> [Either d c]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. d -> Either d c
forall a b. a -> Either a b
Left) ((c -> Either d c) -> [c] -> [Either d c]
forall a b. (a -> b) -> [a] -> [b]
map c -> Either d c
forall a b. b -> Either a b
Right ([c] -> [Either d c]) -> (b -> [c]) -> b -> [Either d c]
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 +++ :: LA b c -> LA b' c' -> LA (Either b b') (Either c c')
+++ LA b' -> [c']
g       = (Either b b' -> [Either c c']) -> LA (Either b b') (Either c c')
forall a b. (a -> [b]) -> LA a b
LA ((Either b b' -> [Either c c']) -> LA (Either b b') (Either c c'))
-> (Either b b' -> [Either c c']) -> LA (Either b b') (Either c c')
forall a b. (a -> b) -> a -> b
$ (b -> [Either c c'])
-> (b' -> [Either c c']) -> Either b b' -> [Either c c']
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((c -> Either c c') -> [c] -> [Either c c']
forall a b. (a -> b) -> [a] -> [b]
map c -> Either c c'
forall a b. a -> Either a b
Left ([c] -> [Either c c']) -> (b -> [c]) -> b -> [Either c c']
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) ((c' -> Either c c') -> [c'] -> [Either c c']
forall a b. (a -> b) -> [a] -> [b]
map c' -> Either c c'
forall a b. b -> Either a b
Right ([c'] -> [Either c c']) -> (b' -> [c']) -> b' -> [Either c c']
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 ||| :: LA b d -> LA c d -> LA (Either b c) d
||| LA c -> [d]
g       = (Either b c -> [d]) -> LA (Either b c) d
forall a b. (a -> [b]) -> LA a b
LA ((Either b c -> [d]) -> LA (Either b c) d)
-> (Either b c -> [d]) -> LA (Either b c) d
forall a b. (a -> b) -> a -> b
$ (b -> [d]) -> (c -> [d]) -> Either b c -> [d]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> [d]
f c -> [d]
g


instance ArrowApply LA where
    app :: LA (LA b c, b) c
app                 = ((LA b c, b) -> [c]) -> LA (LA b c, b) c
forall a b. (a -> [b]) -> LA a b
LA (((LA b c, b) -> [c]) -> LA (LA b c, b) c)
-> ((LA b c, b) -> [c]) -> LA (LA b c, b) c
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 :: (b -> [c]) -> LA b c
arrL                = (b -> [c]) -> LA b c
forall a b. (a -> [b]) -> LA a b
LA
    {-# INLINE arrL #-}
    arr2A :: (b -> LA c d) -> LA (b, c) d
arr2A b -> LA c d
f             = ((b, c) -> [d]) -> LA (b, c) d
forall a b. (a -> [b]) -> LA a b
LA (((b, c) -> [d]) -> LA (b, c) d) -> ((b, c) -> [d]) -> LA (b, c) d
forall a b. (a -> b) -> a -> b
$ \ ~(b
x, c
y) -> LA c d -> c -> [d]
forall a b. LA a b -> a -> [b]
runLA (b -> LA c d
f b
x) c
y
    {-# INLINE arr2A #-}
    isA :: (b -> Bool) -> LA b b
isA b -> Bool
p               = (b -> [b]) -> LA b b
forall a b. (a -> [b]) -> LA a b
LA ((b -> [b]) -> LA b b) -> (b -> [b]) -> LA b b
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 >>. :: LA b c -> ([c] -> [d]) -> LA b d
>>. [c] -> [d]
g          = (b -> [d]) -> LA b d
forall a b. (a -> [b]) -> LA a b
LA ((b -> [d]) -> LA b d) -> (b -> [d]) -> LA b d
forall a b. (a -> b) -> a -> b
$ [c] -> [d]
g ([c] -> [d]) -> (b -> [c]) -> b -> [d]
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 :: LA b c -> c -> LA b c
withDefault LA b c
a c
d     = LA b c
a LA b c -> ([c] -> [c]) -> LA b c
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. \ [c]
x -> if [c] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
x then [c
d] else [c]
x

instance ArrowIf LA where
    ifA :: 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      = (b -> [d]) -> LA b d
forall a b. (a -> [b]) -> LA a b
LA ((b -> [d]) -> LA b d) -> (b -> [d]) -> LA b d
forall a b. (a -> b) -> a -> b
$ \ b
x -> LA b d -> b -> [d]
forall a b. LA a b -> a -> [b]
runLA ( if [c] -> Bool
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 :: LA b c -> LA b c -> LA b c
`orElse` (LA b -> [c]
g)
                        = (b -> [c]) -> LA b c
forall a b. (a -> [b]) -> LA a b
LA ((b -> [c]) -> LA b c) -> (b -> [c]) -> LA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> ( let
                                        res :: [c]
res = b -> [c]
f b
x
                                        in
                                        if [c] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
res
                                        then b -> [c]
g b
x
                                        else [c]
res
                                      )
    {-# INLINE orElse #-}

    spanA :: LA b b -> LA [b] ([b], [b])
spanA LA b b
p             = ([b] -> [([b], [b])]) -> LA [b] ([b], [b])
forall a b. (a -> [b]) -> LA a b
LA (([b] -> [([b], [b])]) -> LA [b] ([b], [b]))
-> ([b] -> [([b], [b])]) -> LA [b] ([b], [b])
forall a b. (a -> b) -> a -> b
$ (([b], [b]) -> [([b], [b])] -> [([b], [b])]
forall a. a -> [a] -> [a]
:[]) (([b], [b]) -> [([b], [b])])
-> ([b] -> ([b], [b])) -> [b] -> [([b], [b])]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (b -> Bool) -> [b] -> ([b], [b])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (b -> Bool) -> b -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([b] -> Bool) -> (b -> [b]) -> b -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LA b b -> b -> [b]
forall a b. LA a b -> a -> [b]
runLA LA b b
p)

    partitionA :: LA b b -> LA [b] ([b], [b])
partitionA  LA b b
p       = ([b] -> [([b], [b])]) -> LA [b] ([b], [b])
forall a b. (a -> [b]) -> LA a b
LA (([b] -> [([b], [b])]) -> LA [b] ([b], [b]))
-> ([b] -> [([b], [b])]) -> LA [b] ([b], [b])
forall a b. (a -> b) -> a -> b
$ (([b], [b]) -> [([b], [b])] -> [([b], [b])]
forall a. a -> [a] -> [a]
:[]) (([b], [b]) -> [([b], [b])])
-> ([b] -> ([b], [b])) -> [b] -> [([b], [b])]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (b -> Bool) -> [b] -> ([b], [b])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not (Bool -> Bool) -> (b -> Bool) -> b -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([b] -> Bool) -> (b -> [b]) -> b -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LA b b -> b -> [b]
forall a b. LA a b -> a -> [b]
runLA LA b b
p)

instance ArrowTree LA

instance ArrowNavigatableTree LA

instance ArrowNF LA where
    rnfA :: LA b c -> LA b c
rnfA (LA b -> [c]
f)         = (b -> [c]) -> LA b c
forall a b. (a -> [b]) -> LA a b
LA ((b -> [c]) -> LA b c) -> (b -> [c]) -> LA b c
forall a b. (a -> b) -> a -> b
$ \ b
x -> let res :: [c]
res = b -> [c]
f b
x
                                      in
                                      [c]
res [c] -> [c] -> [c]
forall a b. NFData a => a -> b -> b
`deepseq` [c]
res

instance ArrowWNF LA

-- ------------------------------------------------------------

-- | conversion of pure list arrows into other possibly more complex
-- list arrows

fromLA          :: ArrowList a => LA b c -> a b c
fromLA :: LA b c -> a b c
fromLA LA b c
f        =  (b -> [c]) -> a b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (LA b c -> b -> [c]
forall a b. LA a b -> a -> [b]
runLA LA b c
f)
{-# INLINE fromLA #-}

-- ------------------------------------------------------------