@@ -1,193 +1,123 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE Rank2Types #-}
2module Reporting.Result
3module Reporting.Result
3 ( Result(..)
4 ( Result(..)
11 , mapError
9 , mapError
18−import Control.Monad.Except (Except, runExcept)
20−import qualified Data.Bag as Bag
21−import qualified Reporting.Annotation as A
22−import qualified Reporting.Region as R
29−data Result info warning error result =
32− , _warnings :: LBag warning
33− , _answer :: Answer (LBag error) result
37−data Answer e a = Ok a | Err e
14+-- TODO try adding INLINE to warn, throw, (>>=), etc.
41− Bag.Bag (A.Located a)
17+import qualified Data.OneOrMore as OneOrMore
18+import qualified Reporting.Warning as Warning
44−data One a = None | One a
51−ok :: (Monoid i) => a -> Result i w e a
53− Result mempty Bag.empty (Ok value)
56−throw :: (Monoid i) => R.Region -> e -> Result i w e a
58− Result mempty Bag.empty (Err (Bag.one (A.A region err)))
25+newtype Result info warnings error a =
30+ -> (info -> warnings -> OneOrMore.OneOrMore error -> result)
31+ -> (info -> warnings -> a -> result)
61−accumulate :: (Monoid i) => i -> a -> Result i w e a
62−accumulate info value =
63− Result info Bag.empty (Ok value)
36+run :: Result () [w] e a -> ([w], Either (OneOrMore.OneOrMore e) a)
39+ (\() w e -> (reverse w, Left e))
40+ (\() w a -> (reverse w, Right a))
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)
48+ok :: a -> Result i w e a
50+ Result $ \i w _ good ->
75−untracked :: (Monoid i) => Result () w e a -> Result i w e a
76−untracked (Result () warnings answer) =
77− Result mempty warnings answer
54+warn :: Warning.Warning -> Result i [Warning.Warning] e ()
56+ Result $ \i warnings _ good ->
57+ good i (warning:warnings) ()
80−from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a
82− case runExcept except of
86− Left errors ->
60+throw :: e -> Result i w e a
87− Result mempty Bag.empty (Err (Bag.fromList (A.map f) errors))
61+throw e =
62+ Result $ \i w bad _ ->
63+ bad i w (OneOrMore.one e)
90mapError :: (e -> e') -> Result i w e a -> Result i w e' a
66mapError :: (e -> e') -> Result i w e a -> Result i w e' a
91−mapError f (Result info warnings rawResult) =
67+mapError func (Result k) =
92− Result info warnings $
68+ Result $ \i w bad good ->
93− case rawResult of
69+ let
94− Ok v ->
70+ bad1 i1 w1 e1 =
95− Ok v
71+ bad i1 w1 (OneOrMore.map func e1)
97− Err msgs ->
73+ k i w bad1 good
98− Err (Bag.map (A.map f) msgs)
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)
106−answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'
107−answerToEither onErr onOk answer =
113− Left (map onErr (Bag.toList errors))
116−oneToValue :: b -> (a -> b) -> One a -> b
77+-- FANCY INSTANCE STUFF
117−oneToValue fallback onOne one =
127−-- EXTRA FANCY HELPERS
130instance Functor (Result i w e) where
80instance Functor (Result i w e) where
131− fmap func (Result info warnings rawResult) =
81+ fmap func (Result k) =
132− case rawResult of
82+ Result $ \i w bad good ->
134− Result info warnings (Ok (func a))
84+ good1 i1 w1 value =
135−
85+ good i1 w1 (func value)
137− Result info warnings (Err msgs)
87+ k i w bad good1
140−instance (Monoid i) => Applicative (Result i w e) where
90+instance Applicative (Result i w e) where
141− pure value =
91+ pure = ok
143−
93+ (<*>) (Result kf) (Result kv) =
144− (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =
94+ Result $ \i w bad good ->
145− Result (mappend info info') (Bag.append warnings warnings') $
95+ let
146− case (resultFunc, resultVal) of
96+ bad1 i1 w1 e1 =
147− (Ok func, Ok val) ->
97+ let
148− Ok (func val)
98+ bad2 i2 w2 e2 = bad i2 w2 (OneOrMore.more e1 e2)
149−
99+ good2 i2 w2 _value = bad i2 w2 e1
150− (Err msgs, Err msgs') ->
100+ in
151− Err (Bag.append msgs msgs')
101+ kv i1 w1 bad2 good2
153− (Err msgs, _) ->
103+ good1 i1 w1 func =
155−
105+ bad2 i2 w2 e2 = bad i2 w2 e2
156− (_, Err msgs) ->
106+ good2 i2 w2 value = good i2 w2 (func value)
158−
108+ kv i1 w1 bad2 good2
160−instance (Monoid i) => Monad (Result i w e) where
113+instance Monad (Result i w e) where
161− return value =
114+ return = ok
164− (>>=) (Result info warnings rawResult) callback =
116+ (>>=) (Result ka) callback =
165− case rawResult of
117+ Result $ \i w bad good ->
167− Result info warnings (Err msg)
171− (Result info' warnings' rawResult') =
119+ good1 i1 w1 a =
175− (mappend info info')
176− (Bag.append warnings warnings')
180−instance Monoid (One a) where
184− mappend left right =
185− case (left, right) of
120+ case callback a of
186− (other, None) ->
121+ Result kb -> kb i1 w1 bad good
188−
123+ ka i w bad good1
193− error "There should only be one!"