    {-# 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))

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