    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

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

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

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

       Implementation of list arrows with a state

    -}

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

    module Control.Arrow.StateListArrow
        ( SLA(..)
        , fromSLA
        )
    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.ArrowState
    import           Control.Arrow.ArrowTree
    import           Control.Arrow.ArrowNavigatableTree

    import           Control.DeepSeq

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

    -- | list arrow combined with a state

    newtype SLA s a b = SLA { forall s a b. SLA s a b -> s -> a -> (s, [b])
    runSLA :: s -> a -> (s, [b]) }

    instance Category (SLA s) where
        id :: forall a. SLA s a a
    id                  = (s -> a -> (s, [a])) -> SLA s a a
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> a -> (s, [a])) -> SLA s a a)
    -> (s -> a -> (s, [a])) -> SLA s a a
    forall a b. (a -> b) -> a -> b
    $ \ s
    s a
    x -> (s
    s, [a
    x])
        {-# INLINE id #-}

        SLA s -> b -> (s, [c])
    g . :: forall b c a. SLA s b c -> SLA s a b -> SLA s a c
    . SLA s -> a -> (s, [b])
    f       = (s -> a -> (s, [c])) -> SLA s a c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> a -> (s, [c])) -> SLA s a c)
    -> (s -> a -> (s, [c])) -> SLA s a c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s a
    x -> let
                                             ~(s
    s1, [b]
    ys) = s -> a -> (s, [b])
    f s
    s a
    x
                                             sequence' :: s -> [b] -> (s, [c])
    sequence' s
    s' []
                                                 = (s
    s', [])
                                             sequence' s
    s' (b
    x':[b]
    xs')
                                                 = let
                                                   ~(s
    s1', [c]
    ys') = s -> b -> (s, [c])
    g s
    s' b
    x'
                                                   ~(s
    s2', [c]
    zs') = s -> [b] -> (s, [c])
    sequence' s
    s1' [b]
    xs'
                                                   in
                                                   (s
    s2', [c]
    ys' [c] -> [c] -> [c]
    forall a. [a] -> [a] -> [a]
    ++ [c]
    zs')
                                             in
                                             s -> [b] -> (s, [c])
    sequence' s
    s1 [b]
    ys

    instance Arrow (SLA s) where
        arr :: forall b c. (b -> c) -> SLA s b c
    arr b -> c
    f               = (s -> b -> (s, [c])) -> SLA s b c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [c])) -> SLA s b c)
    -> (s -> b -> (s, [c])) -> SLA s b c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> (s
    s, [b -> c
    f b
    x])
        {-# INLINE arr #-}

        first :: forall b c d. SLA s b c -> SLA s (b, d) (c, d)
    first (SLA s -> b -> (s, [c])
    f)       = (s -> (b, d) -> (s, [(c, d)])) -> SLA s (b, d) (c, d)
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> (b, d) -> (s, [(c, d)])) -> SLA s (b, d) (c, d))
    -> (s -> (b, d) -> (s, [(c, d)])) -> SLA s (b, d) (c, d)
    forall a b. (a -> b) -> a -> b
    $ \ s
    s ~(b
    x1, d
    x2) -> let
                                                     ~(s
    s', [c]
    ys1) = s -> b -> (s, [c])
    f s
    s b
    x1
                                                     in
                                                     (s
    s', [ (c
    y1, d
    x2) | c
    y1 <- [c]
    ys1 ])

        -- just for efficiency
        second :: forall b c d. SLA s b c -> SLA s (d, b) (d, c)
    second (SLA s -> b -> (s, [c])
    g)      = (s -> (d, b) -> (s, [(d, c)])) -> SLA s (d, b) (d, c)
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> (d, b) -> (s, [(d, c)])) -> SLA s (d, b) (d, c))
    -> (s -> (d, b) -> (s, [(d, c)])) -> SLA s (d, b) (d, c)
    forall a b. (a -> b) -> a -> b
    $ \ s
    s ~(d
    x1, b
    x2) -> let
                                                     ~(s
    s', [c]
    ys2) = s -> b -> (s, [c])
    g s
    s b
    x2
                                                     in
                                                     (s
    s', [ (d
    x1, c
    y2) | c
    y2 <- [c]
    ys2 ])

        -- just for efficiency
        SLA s -> b -> (s, [c])
    f *** :: forall b c b' c'. SLA s b c -> SLA s b' c' -> SLA s (b, b') (c, c')
    *** SLA s -> b' -> (s, [c'])
    g     = (s -> (b, b') -> (s, [(c, c')])) -> SLA s (b, b') (c, c')
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> (b, b') -> (s, [(c, c')])) -> SLA s (b, b') (c, c'))
    -> (s -> (b, b') -> (s, [(c, c')])) -> SLA s (b, b') (c, c')
    forall a b. (a -> b) -> a -> b
    $ \ s
    s ~(b
    x1, b'
    x2) -> let
                                                     ~(s
    s1, [c]
    ys1) = s -> b -> (s, [c])
    f s
    s  b
    x1
                                                     ~(s
    s2, [c']
    ys2) = s -> b' -> (s, [c'])
    g s
    s1 b'
    x2
                                                     in
                                                     (s
    s2, [ (c
    y1, c'
    y2) | c
    y1 <- [c]
    ys1, c'
    y2 <- [c']
    ys2 ])

        -- just for efficiency
        SLA s -> b -> (s, [c])
    f &&& :: forall b c c'. SLA s b c -> SLA s b c' -> SLA s b (c, c')
    &&& SLA s -> b -> (s, [c'])
    g     = (s -> b -> (s, [(c, c')])) -> SLA s b (c, c')
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [(c, c')])) -> SLA s b (c, c'))
    -> (s -> b -> (s, [(c, c')])) -> SLA s b (c, c')
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> let
                                             ~(s
    s1, [c]
    ys1) = s -> b -> (s, [c])
    f s
    s  b
    x
                                             ~(s
    s2, [c']
    ys2) = s -> b -> (s, [c'])
    g s
    s1 b
    x
                                             in
                                             (s
    s2, [ (c
    y1, c'
    y2) | c
    y1 <- [c]
    ys1, c'
    y2 <- [c']
    ys2 ])

    instance ArrowZero (SLA s) where
        zeroArrow :: forall b c. SLA s b c
    zeroArrow           = (s -> b -> (s, [c])) -> SLA s b c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [c])) -> SLA s b c)
    -> (s -> b -> (s, [c])) -> SLA s b c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s -> (s, [c]) -> b -> (s, [c])
    forall a b. a -> b -> a
    const (s
    s, [])
        {-# INLINE zeroArrow #-}

    instance ArrowPlus (SLA s) where
        SLA s -> b -> (s, [c])
    f <+> :: forall b c. SLA s b c -> SLA s b c -> SLA s b c
    <+> SLA s -> b -> (s, [c])
    g     = (s -> b -> (s, [c])) -> SLA s b c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [c])) -> SLA s b c)
    -> (s -> b -> (s, [c])) -> SLA s b c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> let
                                             ~(s
    s1, [c]
    rs1) = s -> b -> (s, [c])
    f s
    s  b
    x
                                             ~(s
    s2, [c]
    rs2) = s -> b -> (s, [c])
    g s
    s1 b
    x
                                             in
                                             (s
    s2, [c]
    rs1 [c] -> [c] -> [c]
    forall a. [a] -> [a] -> [a]
    ++ [c]
    rs2)

    instance ArrowChoice (SLA s) where
        left :: forall b c d. SLA s b c -> SLA s (Either b d) (Either c d)
    left (SLA s -> b -> (s, [c])
    f)        = (s -> Either b d -> (s, [Either c d]))
    -> SLA s (Either b d) (Either c d)
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> Either b d -> (s, [Either c d]))
     -> SLA s (Either b d) (Either c d))
    -> (s -> Either b d -> (s, [Either c d]))
    -> SLA s (Either b d) (Either c d)
    forall a b. (a -> b) -> a -> b
    $ \ s
    s -> let
                                           lf :: b -> (s, [Either c b])
    lf b
    x = (s
    s1, (c -> Either c b) -> [c] -> [Either c b]
    forall a b. (a -> b) -> [a] -> [b]
    map c -> Either c b
    forall a b. a -> Either a b
    Left [c]
    y)
                                                  where
                                                  ~(s
    s1, [c]
    y) = s -> b -> (s, [c])
    f s
    s b
    x
                                           rf :: b -> (s, [Either a b])
    rf b
    x = (s
    s, [b -> Either a b
    forall a b. b -> Either a b
    Right b
    x])
                                           in
                                           (b -> (s, [Either c d]))
    -> (d -> (s, [Either c d])) -> Either b d -> (s, [Either c d])
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either b -> (s, [Either c d])
    forall {b}. b -> (s, [Either c b])
    lf d -> (s, [Either c d])
    forall {b} {a}. b -> (s, [Either a b])
    rf

        right :: forall b c d. SLA s b c -> SLA s (Either d b) (Either d c)
    right (SLA s -> b -> (s, [c])
    f)       = (s -> Either d b -> (s, [Either d c]))
    -> SLA s (Either d b) (Either d c)
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> Either d b -> (s, [Either d c]))
     -> SLA s (Either d b) (Either d c))
    -> (s -> Either d b -> (s, [Either d c]))
    -> SLA s (Either d b) (Either d c)
    forall a b. (a -> b) -> a -> b
    $ \ s
    s -> let
                                           lf :: a -> (s, [Either a b])
    lf a
    x = (s
    s, [a -> Either a b
    forall a b. a -> Either a b
    Left a
    x])
                                           rf :: b -> (s, [Either a c])
    rf b
    x = (s
    s1, (c -> Either a c) -> [c] -> [Either a c]
    forall a b. (a -> b) -> [a] -> [b]
    map c -> Either a c
    forall a b. b -> Either a b
    Right [c]
    y)
                                                  where
                                                  ~(s
    s1, [c]
    y) = s -> b -> (s, [c])
    f s
    s b
    x
                                           in
                                           (d -> (s, [Either d c]))
    -> (b -> (s, [Either d c])) -> Either d b -> (s, [Either d c])
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either d -> (s, [Either d c])
    forall {a} {b}. a -> (s, [Either a b])
    lf b -> (s, [Either d c])
    forall {a}. b -> (s, [Either a c])
    rf

    instance ArrowApply (SLA s) where
        app :: forall b c. SLA s (SLA s b c, b) c
    app                 = (s -> (SLA s b c, b) -> (s, [c])) -> SLA s (SLA s b c, b) c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> (SLA s b c, b) -> (s, [c])) -> SLA s (SLA s b c, b) c)
    -> (s -> (SLA s b c, b) -> (s, [c])) -> SLA s (SLA s b c, b) c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s (SLA s -> b -> (s, [c])
    f, b
    x) -> s -> b -> (s, [c])
    f s
    s b
    x
        {-# INLINE app #-}

    instance ArrowList (SLA s) where
        arrL :: forall b c. (b -> [c]) -> SLA s b c
    arrL b -> [c]
    f              = (s -> b -> (s, [c])) -> SLA s b c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [c])) -> SLA s b c)
    -> (s -> b -> (s, [c])) -> SLA s b c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> (s
    s, (b -> [c]
    f b
    x))
        {-# INLINE arrL #-}
        arr2A :: forall b c d. (b -> SLA s c d) -> SLA s (b, c) d
    arr2A b -> SLA s c d
    f             = (s -> (b, c) -> (s, [d])) -> SLA s (b, c) d
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> (b, c) -> (s, [d])) -> SLA s (b, c) d)
    -> (s -> (b, c) -> (s, [d])) -> SLA s (b, c) d
    forall a b. (a -> b) -> a -> b
    $ \ s
    s ~(b
    x, c
    y) -> SLA s c d -> s -> c -> (s, [d])
    forall s a b. SLA s a b -> s -> a -> (s, [b])
    runSLA (b -> SLA s c d
    f b
    x) s
    s c
    y
        {-# INLINE arr2A #-}
        constA :: forall c b. c -> SLA s b c
    constA c
    c            = (s -> b -> (s, [c])) -> SLA s b c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [c])) -> SLA s b c)
    -> (s -> b -> (s, [c])) -> SLA s b c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s   -> (s, [c]) -> b -> (s, [c])
    forall a b. a -> b -> a
    const (s
    s, [c
    c])
        {-# INLINE constA #-}
        isA :: forall b. (b -> Bool) -> SLA s b b
    isA b -> Bool
    p               = (s -> b -> (s, [b])) -> SLA s b b
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [b])) -> SLA s b b)
    -> (s -> b -> (s, [b])) -> SLA s b b
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> (s
    s, if b -> Bool
    p b
    x then [b
    x] else [])
        {-# INLINE isA #-}
        SLA s -> b -> (s, [c])
    f >>. :: forall b c d. SLA s b c -> ([c] -> [d]) -> SLA s b d
    >>. [c] -> [d]
    g         = (s -> b -> (s, [d])) -> SLA s b d
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [d])) -> SLA s b d)
    -> (s -> b -> (s, [d])) -> SLA s b d
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> let
                                             ~(s
    s1, [c]
    ys) = s -> b -> (s, [c])
    f s
    s b
    x
                                             in
                                             (s
    s1, [c] -> [d]
    g [c]
    ys)
        {-# INLINE (>>.) #-}
        -- just for efficency
        perform :: forall b c. SLA s b c -> SLA s b b
    perform (SLA s -> b -> (s, [c])
    f)     = (s -> b -> (s, [b])) -> SLA s b b
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [b])) -> SLA s b b)
    -> (s -> b -> (s, [b])) -> SLA s b b
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> let
                                             ~(s
    s1, [c]
    _ys) = s -> b -> (s, [c])
    f s
    s b
    x
                                             in
                                             (s
    s1, [b
    x])
        {-# INLINE perform #-}

    instance ArrowIf (SLA s) where
        ifA :: forall b c d. SLA s b c -> SLA s b d -> SLA s b d -> SLA s b d
    ifA (SLA s -> b -> (s, [c])
    p) SLA s b d
    ta SLA s b d
    ea   = (s -> b -> (s, [d])) -> SLA s b d
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [d])) -> SLA s b d)
    -> (s -> b -> (s, [d])) -> SLA s b d
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> let
                                             ~(s
    s1, [c]
    res) = s -> b -> (s, [c])
    p s
    s b
    x
                                             in
                                             SLA s b d -> s -> b -> (s, [d])
    forall s a b. SLA s a b -> s -> a -> (s, [b])
    runSLA ( if [c] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [c]
    res
                                                      then SLA s b d
    ea
                                                      else SLA s b d
    ta
                                                    ) s
    s1 b
    x

        (SLA s -> b -> (s, [c])
    f) orElse :: forall b c. SLA s b c -> SLA s b c -> SLA s b c
    `orElse` SLA s b c
    g
                            = (s -> b -> (s, [c])) -> SLA s b c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [c])) -> SLA s b c)
    -> (s -> b -> (s, [c])) -> SLA s b c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x ->  let
                                              r :: (s, [c])
    r@(s
    s1, [c]
    res) = s -> b -> (s, [c])
    f s
    s b
    x
                                              in
                                              if [c] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [c]
    res
                                              then SLA s b c -> s -> b -> (s, [c])
    forall s a b. SLA s a b -> s -> a -> (s, [b])
    runSLA SLA s b c
    g s
    s1 b
    x
                                              else (s, [c])
    r

    instance ArrowState s (SLA s) where
        changeState :: forall b. (s -> b -> s) -> SLA s b b
    changeState s -> b -> s
    cf      = (s -> b -> (s, [b])) -> SLA s b b
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [b])) -> SLA s b b)
    -> (s -> b -> (s, [b])) -> SLA s b b
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> (s -> b -> s
    cf s
    s b
    x, [b
    x])
        {-# INLINE changeState #-}
        accessState :: forall b c. (s -> b -> c) -> SLA s b c
    accessState s -> b -> c
    af      = (s -> b -> (s, [c])) -> SLA s b c
    forall s a b. (s -> a -> (s, [b])) -> SLA s a b
    SLA ((s -> b -> (s, [c])) -> SLA s b c)
    -> (s -> b -> (s, [c])) -> SLA s b c
    forall a b. (a -> b) -> a -> b
    $ \ s
    s b
    x -> (s
    s, [s -> b -> c
    af s
    s b
    x])
        {-# INLINE accessState #-}

    instance ArrowTree (SLA s)

    instance ArrowNavigatableTree (SLA s)

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

    instance ArrowWNF (SLA s)

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

    -- | conversion of state list arrows into arbitray other
    -- list arrows.
    --
    -- allows running a state list arrow within another arrow:
    --
    -- example:
    --
    -- > ... >>> fromSLA 0 (... setState ... getState ... ) >>> ...
    --
    -- runs a state arrow with initial state 0 (e..g. an Int) within
    -- another arrow sequence

    fromSLA         :: ArrowList a => s -> SLA s b c -> a b c
    fromSLA :: forall (a :: * -> * -> *) s b c.
    ArrowList a =>
    s -> SLA s b c -> a b c
    fromSLA s
    s SLA s b c
    f     =  (b -> [c]) -> a b c
    forall b c. (b -> [c]) -> a b c
    forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
    arrL ((s, [c]) -> [c]
    forall a b. (a, b) -> b
    snd ((s, [c]) -> [c]) -> (b -> (s, [c])) -> b -> [c]
    forall b c a. (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
    . (SLA s b c -> s -> b -> (s, [c])
    forall s a b. SLA s a b -> s -> a -> (s, [b])
    runSLA SLA s b c
    f s
    s))
    {-# INLINE fromSLA #-}

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