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
127
128
129
|
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Arrow.Transformer.Reader
-- 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)
--
-- Arrow transformer that adds a read-only state (i.e. an environment).
module Control.Arrow.Transformer.Reader(
ReaderArrow,
runReader,
ArrowAddReader(..),
) 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 read-only state
-- (or environment). The 'ArrowReader' class contains the operations
-- on this state.
newtype ReaderArrow r a b c = ReaderArrow (a (b, r) c)
-- | Encapsulation of a state-reading computation, taking a value for the
-- state.
--
-- Typical usage in arrow notation:
--
-- > proc p -> ...
-- > (|runReader cmd|) env
runReader :: Arrow a => ReaderArrow r a e b -> a (e,r) b
runReader (ReaderArrow f) = f
-- arrow transformer
instance Arrow a => ArrowTransformer (ReaderArrow r) a where
lift f = ReaderArrow (arr fst >>> f)
-- liftings of standard classes
instance Arrow a => Arrow (ReaderArrow r a) where
arr f = ReaderArrow (arr (f . fst))
ReaderArrow f >>> ReaderArrow g =
ReaderArrow (arr dupenv >>> first f >>> g)
where dupenv (a, r) = ((a, r), r)
first (ReaderArrow f) = ReaderArrow (arr swapsnd >>> first f)
swapsnd :: ((a, r), b) -> ((a, b), r)
swapsnd ~(~(a, r), b) = ((a, b), r)
instance ArrowChoice a => ArrowChoice (ReaderArrow r a) where
left (ReaderArrow f) = ReaderArrow (arr dist' >>> left f)
where dist' :: (Either b c, r) -> Either (b, r) c
dist' (Left b, r) = Left (b, r)
dist' (Right c, _) = Right c
instance ArrowApply a => ArrowApply (ReaderArrow r a) where
app = ReaderArrow
(arr (\((ReaderArrow f, a), r) -> (f, (a, r))) >>> app)
instance ArrowZero a => ArrowZero (ReaderArrow r a) where
zeroArrow = lift zeroArrow
instance ArrowPlus a => ArrowPlus (ReaderArrow r a) where
ReaderArrow f <+> ReaderArrow g = ReaderArrow (f <+> g)
instance ArrowLoop a => ArrowLoop (ReaderArrow r a) where
loop (ReaderArrow f) = ReaderArrow (loop (arr swapsnd >>> f))
-- new instances
instance Arrow a => ArrowReader r (ReaderArrow r a) where
readState = ReaderArrow (arr snd)
newReader (ReaderArrow f) =
ReaderArrow (arr (\((x, _), r) -> (x, r)) >>> f)
instance Arrow a => ArrowAddReader r (ReaderArrow r a) a where
liftReader = lift
elimReader = runReader
-- liftings of other classes
instance ArrowCircuit a => ArrowCircuit (ReaderArrow r a) where
delay x = lift (delay x)
instance ArrowError ex a => ArrowError ex (ReaderArrow r a) where
raise = lift raise
handle (ReaderArrow f) (ReaderArrow h) = ReaderArrow (handle f (arr swapsnd >>> h))
tryInUnless (ReaderArrow f) (ReaderArrow s) (ReaderArrow h) =
ReaderArrow (tryInUnless f (arr swapsnd >>> s) (arr swapsnd >>> h))
newError (ReaderArrow f) = ReaderArrow (newError f)
instance ArrowState s a => ArrowState s (ReaderArrow r a) where
fetch = lift fetch
store = lift store
instance ArrowWriter s a => ArrowWriter s (ReaderArrow r a) where
write = lift write
newWriter (ReaderArrow f) = ReaderArrow (newWriter f)
-- Promotions of encapsulation operators.
instance ArrowAddError ex a a' =>
ArrowAddError ex (ReaderArrow r a) (ReaderArrow r a') where
liftError (ReaderArrow f) = ReaderArrow (liftError f)
elimError (ReaderArrow f) (ReaderArrow h) =
ReaderArrow (elimError f (arr swapsnd >>> h))
instance ArrowAddState s a a' =>
ArrowAddState s (ReaderArrow r a) (ReaderArrow r a') where
liftState (ReaderArrow f) = ReaderArrow (liftState f)
elimState (ReaderArrow f) = ReaderArrow (arr swapsnd >>> elimState f)
-- instance ArrowAddReader r a a' =>
-- ArrowAddReader r (ReaderArrow r a) (ReaderArrow r a') where
-- elimReader (ReaderArrow f) = ReaderArrow (arr swapsnd >>> elimReader f)
instance ArrowAddWriter s a a' =>
ArrowAddWriter s (ReaderArrow r a) (ReaderArrow r a') where
liftWriter (ReaderArrow f) = ReaderArrow (liftWriter f)
elimWriter (ReaderArrow f) = ReaderArrow (elimWriter f)
|
