    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

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

    {- |
       Module     : Control.Arrow.StateListArrow
       Copyright  : Copyright (C) 2005-8 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.DeepSeq

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

    -- | list arrow combined with a state

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

    instance Category (SLA s) where
        id                  = SLA $ \ s x -> (s, [x])

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

    instance Arrow (SLA s) where
        arr f               = SLA $ \ s x -> (s, [f x])

        first (SLA f)       = SLA $ \ s ~(x1, x2) -> let
                                                     ~(s', ys1) = f s x1
                                                     in
                                                     (s', [ (y1, x2) | y1 <- ys1 ])

        -- just for efficiency
        second (SLA g)      = SLA $ \ s ~(x1, x2) -> let
                                                     ~(s', ys2) = g s x2
                                                     in
                                                     (s', [ (x1, y2) | y2 <- ys2 ])

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

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

    instance ArrowZero (SLA s) where
        zeroArrow           = SLA $ \ s -> const (s, [])

    instance ArrowPlus (SLA s) where
        SLA f <+> SLA g     = SLA $ \ s x -> let
                                             ~(s1, rs1) = f s  x
                                             ~(s2, rs2) = g s1 x
                                             in
                                             (s2, rs1 ++ rs2)

    instance ArrowChoice (SLA s) where
        left (SLA f)        = SLA $ \ s -> let
                                           lf x = (s1, map Left y)
                                                  where
                                                  ~(s1, y) = f s x
                                           rf x = (s, [Right x])
                                           in
                                           either lf rf

        right (SLA f)       = SLA $ \ s -> let
                                           lf x = (s, [Left x])
                                           rf x = (s1, map Right y)
                                                  where
                                                  ~(s1, y) = f s x
                                           in
                                           either lf rf

    instance ArrowApply (SLA s) where
        app                 = SLA $ \ s (SLA f, x) -> f s x

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

    instance ArrowIf (SLA s) where
        ifA (SLA p) ta ea   = SLA $ \ s x -> let
                                             ~(s1, res) = p s x
                                             in
                                             runSLA ( if null res
                                                      then ea
                                                      else ta
                                                    ) s1 x

        (SLA f) `orElse` g
                            = SLA $ \ s x ->  let
                                              r@(s1, res) = f s x
                                              in
                                              if null res
                                              then runSLA g s1 x
                                              else r

    instance ArrowState s (SLA s) where
        changeState cf      = SLA $ \ s x -> (cf s x, [x])
        accessState af      = SLA $ \ s x -> (s, [af s x])

    instance ArrowTree (SLA s)

    instance (NFData s) => ArrowNF (SLA s) where
        rnfA (SLA f)        = SLA $ \ s x -> let res = f s x
                                             in
                                             deepseq res res

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

    -- | 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 s f     =  arrL (snd . (runSLA f s))

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