git.iko.soy/elk
on 267f708 help sign in
elk/src/Reporting/Result.hs
179 lines 3.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Reporting.Result where
4import Control.Monad.Except (Except, runExcept)
6import qualified Reporting.Annotation as A
7import qualified Reporting.Bag as Bag
8import qualified Reporting.Region as R
12-- RESULTS
15data Result info warning error result =
16 Result
17 { _info :: info
18 , _warnings :: LBag warning
19 , _answer :: Answer (LBag error) result
20 }
23data Answer e a = Ok a | Err e
26type LBag a =
27 Bag.Bag (A.Located a)
30data One a = None | One a
34-- RESULT HELPERS
37ok :: (Monoid i) => a -> Result i w e a
38ok value =
39 Result mempty Bag.empty (Ok value)
42throw :: (Monoid i) => R.Region -> e -> Result i w e a
43throw region err =
44 Result mempty Bag.empty (Err (Bag.singleton (A.A region err)))
47throwMany :: (Monoid i) => [A.Located e] -> Result i w e a
48throwMany errors =
49 Result mempty Bag.empty (Err (Bag.fromList errors))
52accumulate :: (Monoid i) => i -> a -> Result i w e a
53accumulate info value =
54 Result info Bag.empty (Ok value)
57warn :: (Monoid i) => R.Region -> w -> a -> Result i w e a
58warn region warning a =
59 Result mempty (Bag.singleton (A.A region warning)) (Ok a)
63-- EXTRACTION HELPERS
66from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a
67from f except =
68 case runExcept except of
69 Right answer ->
70 ok answer
72 Left errors ->
73 throwMany (map (A.map f) errors)
76mapError :: (e -> e') -> Result i w e a -> Result i w e' a
77mapError f (Result info warnings rawResult) =
78 Result info warnings $
79 case rawResult of
80 Ok v ->
81 Ok v
83 Err msgs ->
84 Err (Bag.map (A.map f) msgs)
87format :: (Monoid i) => (e -> e') -> Result () w e a -> Result i w e' a
88format func (Result _ warnings answer) =
89 mapError func (Result mempty warnings answer)
92answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'
93answerToEither onErr onOk answer =
94 case answer of
95 Ok value ->
96 Right (onOk value)
98 Err errors ->
99 Left (Bag.toList onErr errors)
102oneToValue :: b -> (a -> b) -> One a -> b
103oneToValue fallback onOne one =
104 case one of
105 None ->
106 fallback
108 One value ->
109 onOne value
113-- EXTRA FANCY HELPERS
116instance Functor (Result i w e) where
117 fmap func (Result info warnings rawResult) =
118 case rawResult of
119 Ok a ->
120 Result info warnings (Ok (func a))
122 Err msgs ->
123 Result info warnings (Err msgs)
126instance (Monoid i) => Applicative (Result i w e) where
127 pure value =
128 ok value
130 (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =
131 Result (mappend info info') (Bag.append warnings warnings') $
132 case (resultFunc, resultVal) of
133 (Ok func, Ok val) ->
134 Ok (func val)
136 (Err msgs, Err msgs') ->
137 Err (Bag.append msgs msgs')
139 (Err msgs, _) ->
140 Err msgs
142 (_, Err msgs) ->
143 Err msgs
146instance (Monoid i) => Monad (Result i w e) where
147 return value =
148 ok value
150 (>>=) (Result info warnings rawResult) callback =
151 case rawResult of
152 Err msg ->
153 Result info warnings (Err msg)
155 Ok value ->
156 let
157 (Result info' warnings' rawResult') =
158 callback value
159 in
160 Result
161 (mappend info info')
162 (Bag.append warnings warnings')
163 rawResult'
166instance Monoid (One a) where
167 mempty =
168 None
170 mappend left right =
171 case (left, right) of
172 (other, None) ->
173 other
175 (None, other) ->
176 other
178 (One _, One _) ->
179 error "There should only be one!"