@@ -1,193 +1,123 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE Rank2Types #-}
23module Reporting.Result
34 ( Result(..)
4− , Answer(..)
5+ , run
56 , ok
6− , throw
7− , accumulate
87 , warn
9− , untracked
10− , from
8+ , throw
119 , mapError
12− , format
13− , answerToEither
14− , oneToValue
1510 )
1611 where
1712
18−import Control.Monad.Except (Except, runExcept)
19−
20−import qualified Data.Bag as Bag
21−import qualified Reporting.Annotation as A
22−import qualified Reporting.Region as R
23−
24−
25−
26−-- RESULTS
27−
28−
29−data Result info warning error result =
30− Result
31− { _info :: info
32− , _warnings :: LBag warning
33− , _answer :: Answer (LBag error) result
34− }
35−
36−
37−data Answer e a = Ok a | Err e
3813
14+-- TODO try adding INLINE to warn, throw, (>>=), etc.
3915
40−type LBag a =
41− Bag.Bag (A.Located a)
4216
17+import qualified Data.OneOrMore as OneOrMore
18+import qualified Reporting.Warning as Warning
4319
44−data One a = None | One a
4520
4621
22+-- RESULT
4723
48−-- RESULT HELPERS
49−
50−
51−ok :: (Monoid i) => a -> Result i w e a
52−ok value =
53− Result mempty Bag.empty (Ok value)
54−
55−
56−throw :: (Monoid i) => R.Region -> e -> Result i w e a
57−throw region err =
58− Result mempty Bag.empty (Err (Bag.one (A.A region err)))
5924
25+newtype Result info warnings error a =
26+ Result (
27+ forall result.
28+ info
29+ -> warnings
30+ -> (info -> warnings -> OneOrMore.OneOrMore error -> result)
31+ -> (info -> warnings -> a -> result)
32+ -> result
33+ )
6034
61−accumulate :: (Monoid i) => i -> a -> Result i w e a
62−accumulate info value =
63− Result info Bag.empty (Ok value)
6435
36+run :: Result () [w] e a -> ([w], Either (OneOrMore.OneOrMore e) a)
37+run (Result k) =
38+ k () []
39+ (\() w e -> (reverse w, Left e))
40+ (\() w a -> (reverse w, Right a))
6541
66−warn :: (Monoid i) => R.Region -> w -> a -> Result i w e a
67−warn region warning a =
68− Result mempty (Bag.one (A.A region warning)) (Ok a)
6942
7043
44+-- HELPERS
7145
72−-- EXTRACTION HELPERS
7346
47+{-# INLINE ok #-}
48+ok :: a -> Result i w e a
49+ok a =
50+ Result $ \i w _ good ->
51+ good i w a
7452
75−untracked :: (Monoid i) => Result () w e a -> Result i w e a
76−untracked (Result () warnings answer) =
77− Result mempty warnings answer
7853
54+warn :: Warning.Warning -> Result i [Warning.Warning] e ()
55+warn warning =
56+ Result $ \i warnings _ good ->
57+ good i (warning:warnings) ()
7958
80−from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a
81−from f except =
82− case runExcept except of
83− Right answer ->
84− ok answer
8559
86− Left errors ->
87− Result mempty Bag.empty (Err (Bag.fromList (A.map f) errors))
60+throw :: e -> Result i w e a
61+throw e =
62+ Result $ \i w bad _ ->
63+ bad i w (OneOrMore.one e)
8864
8965
9066mapError :: (e -> e') -> Result i w e a -> Result i w e' a
91−mapError f (Result info warnings rawResult) =
92− Result info warnings $
93− case rawResult of
94− Ok v ->
95− Ok v
96−
97− Err msgs ->
98− Err (Bag.map (A.map f) msgs)
99−
100−
101−format :: (Monoid i) => (e -> e') -> Result () w e a -> Result i w e' a
102−format func (Result _ warnings answer) =
103− mapError func (Result mempty warnings answer)
104−
105−
106−answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'
107−answerToEither onErr onOk answer =
108− case answer of
109− Ok value ->
110− Right (onOk value)
67+mapError func (Result k) =
68+ Result $ \i w bad good ->
69+ let
70+ bad1 i1 w1 e1 =
71+ bad i1 w1 (OneOrMore.map func e1)
72+ in
73+ k i w bad1 good
11174
112− Err errors ->
113− Left (map onErr (Bag.toList errors))
11475
11576
116−oneToValue :: b -> (a -> b) -> One a -> b
117−oneToValue fallback onOne one =
118− case one of
119− None ->
120− fallback
121−
122− One value ->
123− onOne value
124−
125−
126−
127−-- EXTRA FANCY HELPERS
77+-- FANCY INSTANCE STUFF
12878
12979
13080instance Functor (Result i w e) where
131− fmap func (Result info warnings rawResult) =
132− case rawResult of
133− Ok a ->
134− Result info warnings (Ok (func a))
135−
136− Err msgs ->
137− Result info warnings (Err msgs)
138−
139−
140−instance (Monoid i) => Applicative (Result i w e) where
141− pure value =
142− ok value
143−
144− (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =
145− Result (mappend info info') (Bag.append warnings warnings') $
146− case (resultFunc, resultVal) of
147− (Ok func, Ok val) ->
148− Ok (func val)
149−
150− (Err msgs, Err msgs') ->
151− Err (Bag.append msgs msgs')
152−
153− (Err msgs, _) ->
154− Err msgs
155−
156− (_, Err msgs) ->
157− Err msgs
158−
159−
160−instance (Monoid i) => Monad (Result i w e) where
161− return value =
162− ok value
163−
164− (>>=) (Result info warnings rawResult) callback =
165− case rawResult of
166− Err msg ->
167− Result info warnings (Err msg)
168−
169− Ok value ->
170− let
171− (Result info' warnings' rawResult') =
172− callback value
173− in
174− Result
175− (mappend info info')
176− (Bag.append warnings warnings')
177− rawResult'
178−
179−
180−instance Monoid (One a) where
181− mempty =
182− None
183−
184− mappend left right =
185− case (left, right) of
186− (other, None) ->
187− other
188−
189− (None, other) ->
190− other
191−
192− (One _, One _) ->
193− error "There should only be one!"
81+ fmap func (Result k) =
82+ Result $ \i w bad good ->
83+ let
84+ good1 i1 w1 value =
85+ good i1 w1 (func value)
86+ in
87+ k i w bad good1
88+
89+
90+instance Applicative (Result i w e) where
91+ pure = ok
92+
93+ (<*>) (Result kf) (Result kv) =
94+ Result $ \i w bad good ->
95+ let
96+ bad1 i1 w1 e1 =
97+ let
98+ bad2 i2 w2 e2 = bad i2 w2 (OneOrMore.more e1 e2)
99+ good2 i2 w2 _value = bad i2 w2 e1
100+ in
101+ kv i1 w1 bad2 good2
102+
103+ good1 i1 w1 func =
104+ let
105+ bad2 i2 w2 e2 = bad i2 w2 e2
106+ good2 i2 w2 value = good i2 w2 (func value)
107+ in
108+ kv i1 w1 bad2 good2
109+ in
110+ kf i w bad1 good1
111+
112+
113+instance Monad (Result i w e) where
114+ return = ok
115+
116+ (>>=) (Result ka) callback =
117+ Result $ \i w bad good ->
118+ let
119+ good1 i1 w1 a =
120+ case callback a of
121+ Result kb -> kb i1 w1 bad good
122+ in
123+ ka i w bad good1