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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Arrow.Transformer.Error
-- Copyright : (c) Ross Paterson 2003
-- License : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer : R.Paterson@city.ac.uk
-- Stability : experimental
-- Portability : non-portable (multi-parameter type classes)
--
-- An arrow transformer that adds error handling.
--
-- /TODO:/ the operations here are inconsistent with other arrow transformers.
module Control.Arrow.Transformer.Error(
ErrorArrow(ErrorArrow),
runError,
ArrowAddError(..),
) where
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Control.Applicative
import Control.Arrow
import Control.Category
import Data.Monoid
#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif
import Prelude hiding (id,(.))
-- | An arrow that augments an existing arrow with possible errors.
-- The 'ArrowError' class contains methods for raising and handling
-- these errors.
newtype ErrorArrow ex a b c = ErrorArrow (a b (Either ex c))
rstrength :: (Either ex a, b) -> Either ex (a, b)
rstrength (Left ex, _) = Left ex
rstrength (Right a, b) = Right (a, b)
-- | Encapsulate an error-raising computation,
-- by completely handling any errors.
--
-- Typical usage in arrow notation:
--
-- > proc p -> ...
-- > body `runError` \ex -> handler
runError :: ArrowChoice a =>
ErrorArrow ex a e b -- ^ computation that may raise errors
-> a (e,ex) b -- ^ computation to handle errors
-> a e b
runError (ErrorArrow f) h =
arr id &&& f >>> arr strength >>> h ||| arr id
where
strength (x, Left y) = Left (x, y)
strength (_, Right z) = Right z
-- transformer
instance ArrowChoice a => ArrowTransformer (ErrorArrow ex) a where
lift f = ErrorArrow (f >>> arr Right)
-- liftings of standard classes
instance ArrowChoice a => Category (ErrorArrow ex a) where
id = ErrorArrow (arr Right)
ErrorArrow f . ErrorArrow g =
ErrorArrow (arr (either Left id) . right f . g)
instance ArrowChoice a => Arrow (ErrorArrow ex a) where
arr f = ErrorArrow (arr (Right . f))
first (ErrorArrow f) = ErrorArrow (first f >>> arr rstrength)
instance ArrowChoice a => ArrowChoice (ErrorArrow ex a) where
left (ErrorArrow f) = ErrorArrow (left f >>> arr assocsum)
assocsum :: Either (Either a b) c -> Either a (Either b c)
assocsum (Left (Left a)) = Left a
assocsum (Left (Right b)) = Right (Left b)
assocsum (Right c) = Right (Right c)
instance (ArrowChoice a, ArrowApply a) => ArrowApply (ErrorArrow ex a) where
app = ErrorArrow (arr (\(ErrorArrow f, x) -> (f, x)) >>> app)
-- this instance has the right type, but it doesn't satisfy right
-- tightening, or sliding of non-strict functions.
instance (ArrowChoice a, ArrowLoop a) => ArrowLoop (ErrorArrow ex a) where
loop (ErrorArrow f) = ErrorArrow (loop (f >>> arr dist))
where
dist x = (fstRight x, snd $ fromRight x)
fstRight (Left x) = Left x
fstRight (Right (x,_)) = Right x
fromRight (Left _) = error "fromRight"
fromRight (Right y) = y
-- Other instances
instance ArrowChoice a => Functor (ErrorArrow ex a b) where
fmap f g = g >>> arr f
instance ArrowChoice a => Applicative (ErrorArrow ex a b) where
pure x = arr (const x)
f <*> g = f &&& g >>> arr (uncurry id)
instance (Monoid ex, ArrowChoice a) => Alternative (ErrorArrow ex a b) where
empty = zeroArrow
f <|> g = f <+> g
#if MIN_VERSION_base(4,9,0)
instance (Monoid ex, ArrowChoice a) => Semigroup (ErrorArrow ex a b c) where
(<>) = (<+>)
#endif
instance (Monoid ex, ArrowChoice a) => Monoid (ErrorArrow ex a b c) where
mempty = zeroArrow
#if !(MIN_VERSION_base(4,11,0))
mappend = (<+>)
#endif
-- fresh instances
instance ArrowChoice a => ArrowError ex (ErrorArrow ex a) where
raise = ErrorArrow (arr Left)
handle (ErrorArrow f) (ErrorArrow h) =
ErrorArrow (arr id &&& f >>> arr strength >>> h ||| arr Right)
where
strength (x, Left y) = Left (x, y)
strength (_, Right z) = Right z
tryInUnless (ErrorArrow f) (ErrorArrow s) (ErrorArrow h) =
ErrorArrow (arr id &&& f >>> arr distr >>> h ||| s)
where
distr (b, Left ex) = Left (b, ex)
distr (b, Right c) = Right (b, c)
instance ArrowChoice a => ArrowAddError ex (ErrorArrow ex a) a where
liftError = lift
elimError = runError
instance (Monoid ex, ArrowChoice a) => ArrowZero (ErrorArrow ex a) where
zeroArrow = ErrorArrow (arr (const (Left mempty)))
instance (Monoid ex, ArrowChoice a) => ArrowPlus (ErrorArrow ex a) where
f <+> g = handle f $ handle (arr fst >>> g) $
ErrorArrow (arr (\((_,ex1), ex2) -> Left (ex1 `mappend` ex2)))
-- liftings of other arrow classes
-- specializations of general promotions
instance (ArrowReader r a, ArrowChoice a) =>
ArrowReader r (ErrorArrow ex a) where
readState = lift readState
newReader (ErrorArrow f) = ErrorArrow (newReader f)
instance (ArrowState s a, ArrowChoice a) =>
ArrowState s (ErrorArrow ex a) where
fetch = lift fetch
store = lift store
instance (ArrowWriter w a, ArrowChoice a) =>
ArrowWriter w (ErrorArrow ex a) where
write = lift write
newWriter (ErrorArrow f) = ErrorArrow (newWriter f >>> arr rstrength)
-- promotions
instance (ArrowAddReader r a a', ArrowChoice a, ArrowChoice a') =>
ArrowAddReader r (ErrorArrow ex a) (ErrorArrow ex a') where
liftReader (ErrorArrow f) = ErrorArrow (liftReader f)
elimReader (ErrorArrow f) = ErrorArrow (elimReader f)
instance (ArrowAddState s a a', ArrowChoice a, ArrowChoice a') =>
ArrowAddState s (ErrorArrow ex a) (ErrorArrow ex a') where
liftState (ErrorArrow f) = ErrorArrow (liftState f)
elimState (ErrorArrow f) = ErrorArrow (elimState f >>> arr rstrength)
instance (ArrowAddWriter w a a', ArrowChoice a, ArrowChoice a') =>
ArrowAddWriter w (ErrorArrow ex a) (ErrorArrow ex a') where
liftWriter (ErrorArrow f) = ErrorArrow (liftWriter f)
elimWriter (ErrorArrow f) = ErrorArrow (elimWriter f >>> arr rstrength)
|
