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

    {- |
       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 g :: b -> [c]
    g . :: LA b c -> LA a b -> LA a c
    . LA f :: 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 f :: 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
    $ \ x :: b
    x -> [b -> c
    f b
    x]
        {-# INLINE arr #-}
        first :: LA b c -> LA (b, d) (c, d)
    first (LA f :: 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
    $ \ ~(x1 :: b
    x1, x2 :: 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 g :: 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
    $ \ ~(x1 :: d
    x1, x2 :: b
    x2) -> [ (d
    x1, c
    y2) | c
    y2 <- b -> [c]
    g b
    x2 ]
        LA f :: b -> [c]
    f *** :: LA b c -> LA b' c' -> LA (b, b') (c, c')
    *** LA g :: 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
    $ \ ~(x1 :: b
    x1, x2 :: b'
    x2) -> [ (c
    y1, c'
    y2) | c
    y1 <- b -> [c]
    f b
    x1, c'
    y2 <- b' -> [c']
    g b'
    x2]
        LA f :: b -> [c]
    f &&& :: LA b c -> LA b c' -> LA b (c, c')
    &&& LA g :: 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
    $ \ x :: 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 f :: b -> [c]
    f <+> :: LA b c -> LA b c -> LA b c
    <+> LA g :: 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
    $ \ x :: 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 f :: 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 f :: 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 f :: b -> [c]
    f +++ :: LA b c -> LA b' c' -> LA (Either b b') (Either c c')
    +++ LA g :: 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 f :: b -> [d]
    f ||| :: LA b d -> LA c d -> LA (Either b c) d
    ||| LA g :: 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 f :: b -> [c]
    f, x :: 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 f :: 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
    $ \ ~(x :: b
    x, y :: 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 p :: 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
    $ \ x :: b
    x -> if b -> Bool
    p b
    x then [b
    x] else []
        {-# INLINE isA #-}
        LA f :: b -> [c]
    f >>. :: LA b c -> ([c] -> [d]) -> LA b d
    >>. g :: [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 a :: LA b c
    a d :: 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
    >>. \ x :: [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 p :: b -> [c]
    p) t :: LA b d
    t e :: 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
    $ \ x :: 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 f :: b -> [c]
    f) orElse :: LA b c -> LA b c -> LA b c
    `orElse` (LA g :: 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
    $ \ x :: 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 p :: 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  p :: 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 f :: 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
    $ \ x :: 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 f :: 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 #-}

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