{-# 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
s x :: a
x -> (s
s, [a
x])
    {-# INLINE id #-}

    SLA g :: s -> b -> (s, [c])
g . :: SLA s b c -> SLA s a b -> SLA s a c
. SLA f :: 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
s x :: a
x -> let
                                         ~(s1 :: s
s1, ys :: [b]
ys) = s -> a -> (s, [b])
f s
s a
x
                                         sequence' :: s -> [b] -> (s, [c])
sequence' s' :: s
s' []
                                             = (s
s', [])
                                         sequence' s' :: s
s' (x' :: b
x':xs' :: [b]
xs')
                                             = let
                                               ~(s1' :: s
s1', ys' :: [c]
ys') = s -> b -> (s, [c])
g s
s' b
x'
                                               ~(s2' :: s
s2', zs' :: [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 f :: 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
s x :: b
x -> (s
s, [b -> c
f b
x])
    {-# INLINE arr #-}

    first :: SLA s b c -> SLA s (b, d) (c, d)
first (SLA f :: 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
s ~(x1 :: b
x1, x2 :: d
x2) -> let
                                                 ~(s' :: s
s', ys1 :: [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 g :: 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
s ~(x1 :: d
x1, x2 :: b
x2) -> let
                                                 ~(s' :: s
s', ys2 :: [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 f :: s -> b -> (s, [c])
f *** :: SLA s b c -> SLA s b' c' -> SLA s (b, b') (c, c')
*** SLA g :: 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
s ~(x1 :: b
x1, x2 :: b'
x2) -> let
                                                 ~(s1 :: s
s1, ys1 :: [c]
ys1) = s -> b -> (s, [c])
f s
s  b
x1
                                                 ~(s2 :: s
s2, ys2 :: [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 f :: s -> b -> (s, [c])
f &&& :: SLA s b c -> SLA s b c' -> SLA s b (c, c')
&&& SLA g :: 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
s x :: b
x -> let
                                         ~(s1 :: s
s1, ys1 :: [c]
ys1) = s -> b -> (s, [c])
f s
s  b
x
                                         ~(s2 :: s
s2, ys2 :: [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 -> (s, [c]) -> b -> (s, [c])
forall a b. a -> b -> a
const (s
s, [])
    {-# INLINE zeroArrow #-}


instance ArrowPlus (SLA s) where
    SLA f :: s -> b -> (s, [c])
f <+> :: SLA s b c -> SLA s b c -> SLA s b c
<+> SLA g :: 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
s x :: b
x -> let
                                         ~(s1 :: s
s1, rs1 :: [c]
rs1) = s -> b -> (s, [c])
f s
s  b
x
                                         ~(s2 :: s
s2, rs2 :: [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 f :: 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
s -> let
                                       lf :: b -> (s, [Either c b])
lf x :: 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
                                              ~(s1 :: s
s1, y :: [c]
y) = s -> b -> (s, [c])
f s
s b
x
                                       rf :: b -> (s, [Either a b])
rf x :: 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 f :: 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
s -> let
                                       lf :: a -> (s, [Either a b])
lf x :: 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 x :: 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
                                              ~(s1 :: s
s1, y :: [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
s (SLA f :: s -> b -> (s, [c])
f, x :: 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 f :: 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
s x :: b
x -> (s
s, (b -> [c]
f b
x))
    {-# INLINE arrL #-}
    arr2A :: (b -> SLA s c d) -> SLA s (b, c) d
arr2A f :: 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
s ~(x :: b
x, y :: 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
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   -> (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 p :: 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
s x :: b
x -> (s
s, if b -> Bool
p b
x then [b
x] else [])
    {-# INLINE isA #-}
    SLA f :: s -> b -> (s, [c])
f >>. :: SLA s b c -> ([c] -> [d]) -> SLA s b d
>>. g :: [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
s x :: b
x -> let
                                         ~(s1 :: s
s1, ys :: [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 f :: 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
s x :: b
x -> let
                                         ~(s1 :: s
s1, _ys :: [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 p :: s -> b -> (s, [c])
p) ta :: SLA s b d
ta ea :: 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
s x :: b
x -> let
                                         ~(s1 :: s
s1, res :: [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 f :: s -> b -> (s, [c])
f) orElse :: SLA s b c -> SLA s b c -> SLA s b c
`orElse` g :: 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
s x :: b
x ->  let
                                          r :: (s, [c])
r@(s1 :: s
s1, res :: [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 cf :: 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
s x :: b
x -> (s -> b -> s
cf s
s b
x, [b
x])
    {-# INLINE changeState #-}
    accessState :: (s -> b -> c) -> SLA s b c
accessState af :: 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
s x :: 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 f :: 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
s x :: 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
s f :: 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 #-}


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