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

{- |
   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 { 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 ]

    -- just for efficiency

    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

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

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

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

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