1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Arrow.Transformer.State
-- Copyright : (c) Ross Paterson 2003
-- License : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer : ross@soi.city.ac.uk
-- Stability : experimental
-- Portability : non-portable (multi-parameter type classes)
--
-- An arrow transformer that adds a modifiable state,
-- based of section 9 of /Generalising Monads to Arrows/, by John Hughes,
-- /Science of Computer Programming/ 37:67-111, May 2000.
module Control.Arrow.Transformer.State(
StateArrow,
runState,
ArrowAddState(..),
) where
import Control.Arrow
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
-- | An arrow type that augments an existing arrow with a modifiable
-- state. The 'ArrowState' class contains the operations on this state.
newtype StateArrow s a b c = ST (a (b, s) (c, s))
swapsnd :: ((a, b), c) -> ((a, c), b)
swapsnd ~(~(x, y), z) = ((x, z), y)
instance Arrow a => Arrow (StateArrow s a) where
arr f = ST (arr (\(x, s) -> (f x, s)))
ST f >>> ST g = ST (f >>> g)
first (ST f) = ST (arr swapsnd >>> first f >>> arr swapsnd)
instance Arrow a => ArrowTransformer (StateArrow s) a where
lift f = ST (first f)
-- | Encapsulation of a state-using computation, exposing the initial
-- and final states.
--
-- Typical usage in arrow notation:
--
-- > proc p -> do
-- > ...
-- > (result, final_state) <- (|runState cmd|) init_state
runState :: Arrow a => StateArrow s a e b -> a (e,s) (b,s)
runState (ST f) = f
-- operations
instance Arrow a => ArrowState s (StateArrow s a) where
fetch = ST (arr (\(_, s) -> (s, s)))
store = ST (arr (\(s, _) -> ((), s)))
instance Arrow a => ArrowAddState s (StateArrow s a) a where
liftState = lift
elimState = runState
-- The following promotions follow directly from the arrow transformer.
instance ArrowZero a => ArrowZero (StateArrow s a) where
zeroArrow = ST zeroArrow
instance ArrowCircuit a => ArrowCircuit (StateArrow s a) where
delay x = lift (delay x)
instance ArrowError ex a => ArrowError ex (StateArrow s a) where
raise = lift raise
handle (ST f) (ST h) = ST (handle f (arr swapsnd >>> h))
tryInUnless (ST f) (ST s) (ST h) =
ST (tryInUnless f (arr new_state >>> s) (arr swapsnd >>> h))
where new_state ((b,_),(c,s')) = ((b,c),s')
newError (ST f) = ST (newError f &&& arr snd >>> arr h)
where h (Left ex, s) = (Left ex, s)
h (Right (c, s'), _) = (Right c, s')
-- Note that in each case the error handler gets the original state.
instance ArrowReader r a => ArrowReader r (StateArrow s a) where
readState = lift readState
newReader (ST f) = ST (arr swapsnd >>> newReader f)
instance ArrowWriter w a => ArrowWriter w (StateArrow s a) where
write = lift write
newWriter (ST f) = ST (newWriter f >>> arr swapsnd)
-- liftings of standard classes
instance ArrowChoice a => ArrowChoice (StateArrow s a) where
left (ST f) = ST (arr distr >>> left f >>> arr undistr)
where distr (Left y, s) = Left (y, s)
distr (Right z, s) = Right (z, s)
undistr (Left (y, s)) = (Left y, s)
undistr (Right (z, s)) = (Right z, s)
instance ArrowApply a => ArrowApply (StateArrow s a) where
app = ST (arr (\((ST f, x), s) -> (f, (x, s))) >>> app)
instance ArrowLoop a => ArrowLoop (StateArrow s a) where
loop (ST f) = ST (loop (arr swapsnd >>> f >>> arr swapsnd))
instance ArrowPlus a => ArrowPlus (StateArrow s a) where
ST f <+> ST g = ST (f <+> g)
-- promotions
instance ArrowAddReader r a a' =>
ArrowAddReader r (StateArrow s a) (StateArrow s a') where
liftReader (ST f) = ST (liftReader f)
elimReader (ST f) = ST (arr swapsnd >>> elimReader f)
instance ArrowAddWriter w a a' =>
ArrowAddWriter w (StateArrow s a) (StateArrow s a') where
liftWriter (ST f) = ST (liftWriter f)
elimWriter (ST f) = ST (elimWriter f >>> arr swapsnd)
instance ArrowAddError ex a a' =>
ArrowAddError ex (StateArrow s a) (StateArrow s a') where
liftError (ST f) = ST (liftError f)
elimError (ST f) (ST h) = ST (elimError f (arr swapsnd >>> h))
|
