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
|
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Arrow.Transformer.Error
-- 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 error handling.
--
-- /TODO:/ the operations here are inconsistent with other arrow transformers.
module Control.Arrow.Transformer.Error(
ErrorArrow,
runError,
ArrowAddError(..),
) where
import Control.Arrow
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Data.Monoid
-- | 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 => Arrow (ErrorArrow ex a) where
arr f = ErrorArrow (arr (Right . f))
ErrorArrow f >>> ErrorArrow g =
ErrorArrow (f >>> right g >>> arr (either Left id))
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
-- 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)
|
