{-# 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 { SLA s a b -> s -> a -> (s, [b])
runSLA :: s -> a -> (s, [b]) }

instance Category (SLA s) where
    id :: 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 . :: 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 :: (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 :: 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 :: 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 *** :: 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 &&& :: 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 :: 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 <+> :: 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 :: 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 :: 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 :: 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 :: (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 :: (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 :: 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 :: (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 >>. :: 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 :: 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 :: 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 (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 :: 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 (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 :: (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 :: (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 :: 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 :: s -> SLA s b c -> a b c
fromSLA s
s SLA s b c
f     =  (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 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 #-}


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