git.iko.soy/elk
on c19392f help sign in
elk/src/Reporting/Result.hs
186 lines 3.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Reporting.Result
3 ( Result(..)
4 , ok
5 , throw
6 , accumulate
7 , warn
8 , from
9 , mapError
10 , format
11 , answerToEither
12 , oneToValue
13 )
14 where
16import Control.Monad.Except (Except, runExcept)
18import qualified Data.Bag as Bag
19import qualified Reporting.Annotation as A
20import qualified Reporting.Region as R
24-- RESULTS
27data Result info warning error result =
28 Result
29 { _info :: info
30 , _warnings :: LBag warning
31 , _answer :: Answer (LBag error) result
32 }
35data Answer e a = Ok a | Err e
38type LBag a =
39 Bag.Bag (A.Located a)
42data One a = None | One a
46-- RESULT HELPERS
49ok :: (Monoid i) => a -> Result i w e a
50ok value =
51 Result mempty Bag.empty (Ok value)
54throw :: (Monoid i) => R.Region -> e -> Result i w e a
55throw region err =
56 Result mempty Bag.empty (Err (Bag.one (A.A region err)))
59accumulate :: (Monoid i) => i -> a -> Result i w e a
60accumulate info value =
61 Result info Bag.empty (Ok value)
64warn :: (Monoid i) => R.Region -> w -> a -> Result i w e a
65warn region warning a =
66 Result mempty (Bag.one (A.A region warning)) (Ok a)
70-- EXTRACTION HELPERS
73from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a
74from f except =
75 case runExcept except of
76 Right answer ->
77 ok answer
79 Left errors ->
80 Result mempty Bag.empty (Err (Bag.fromList (A.map f) errors))
83mapError :: (e -> e') -> Result i w e a -> Result i w e' a
84mapError f (Result info warnings rawResult) =
85 Result info warnings $
86 case rawResult of
87 Ok v ->
88 Ok v
90 Err msgs ->
91 Err (Bag.map (A.map f) msgs)
94format :: (Monoid i) => (e -> e') -> Result () w e a -> Result i w e' a
95format func (Result _ warnings answer) =
96 mapError func (Result mempty warnings answer)
99answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'
100answerToEither onErr onOk answer =
101 case answer of
102 Ok value ->
103 Right (onOk value)
105 Err errors ->
106 Left (map onErr (Bag.toList errors))
109oneToValue :: b -> (a -> b) -> One a -> b
110oneToValue fallback onOne one =
111 case one of
112 None ->
113 fallback
115 One value ->
116 onOne value
120-- EXTRA FANCY HELPERS
123instance Functor (Result i w e) where
124 fmap func (Result info warnings rawResult) =
125 case rawResult of
126 Ok a ->
127 Result info warnings (Ok (func a))
129 Err msgs ->
130 Result info warnings (Err msgs)
133instance (Monoid i) => Applicative (Result i w e) where
134 pure value =
135 ok value
137 (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =
138 Result (mappend info info') (Bag.append warnings warnings') $
139 case (resultFunc, resultVal) of
140 (Ok func, Ok val) ->
141 Ok (func val)
143 (Err msgs, Err msgs') ->
144 Err (Bag.append msgs msgs')
146 (Err msgs, _) ->
147 Err msgs
149 (_, Err msgs) ->
150 Err msgs
153instance (Monoid i) => Monad (Result i w e) where
154 return value =
155 ok value
157 (>>=) (Result info warnings rawResult) callback =
158 case rawResult of
159 Err msg ->
160 Result info warnings (Err msg)
162 Ok value ->
163 let
164 (Result info' warnings' rawResult') =
165 callback value
166 in
167 Result
168 (mappend info info')
169 (Bag.append warnings warnings')
170 rawResult'
173instance Monoid (One a) where
174 mempty =
175 None
177 mappend left right =
178 case (left, right) of
179 (other, None) ->
180 other
182 (None, other) ->
183 other
185 (One _, One _) ->
186 error "There should only be one!"