{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
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
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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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' 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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) = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 ])
second :: forall b c d. SLA s b c -> SLA s (d, b) (d, c)
second (SLA s -> b -> (s, [c])
g) = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 ])
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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 ])
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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA forall a b. (a -> b) -> a -> b
$ \ s
s -> 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 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) = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA forall a b. (a -> b) -> a -> b
$ \ s
s -> let
lf :: b -> (s, [Either c b])
lf b
x = (s
s1, forall a b. (a -> b) -> [a] -> [b]
map 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, [forall a b. b -> Either a b
Right b
x])
in
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {b}. b -> (s, [Either c b])
lf 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) = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA forall a b. (a -> b) -> a -> b
$ \ s
s -> let
lf :: a -> (s, [Either a b])
lf a
x = (s
s, [forall a b. a -> Either a b
Left a
x])
rf :: b -> (s, [Either a c])
rf b
x = (s
s1, forall a b. (a -> b) -> [a] -> [b]
map 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
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a} {b}. a -> (s, [Either a b])
lf 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA forall a b. (a -> b) -> a -> b
$ \ s
s ~(b
x, c
y) -> 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA forall a b. (a -> b) -> a -> b
$ \ s
s -> 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 (>>.) #-}
perform :: forall b c. SLA s b c -> SLA s b b
perform (SLA s -> b -> (s, [c])
f) = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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
forall s a b. SLA s a b -> s -> a -> (s, [b])
runSLA ( if 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
= forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
res
then 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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 = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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) = forall s a b. (s -> a -> (s, [b])) -> SLA s a b
SLA 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
forall a b. (a, b) -> b
snd (s, [c])
res forall a b. NFData a => a -> b -> b
`deepseq` (s, [c])
res
instance ArrowWNF (SLA s)
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 = forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (forall a b. (a, b) -> b
snd forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall s a b. SLA s a b -> s -> a -> (s, [b])
runSLA SLA s b c
f s
s))
{-# INLINE fromSLA #-}