git.iko.soy/elk
on master help sign in
Make error reporting parallel

Rename Reporting.Task to Reporting.Result, and make it so the applicative version lets us keep gathering warnings and errors.

commitb4657b904d7b0119fc4d975fbd7ae62f779fb948 authorEvan Czaplicki <info@elm-lang.org> dateMon 4 May 2015, 09:11 (12 years ago) parent357dedf
9 files changed+225−109
compare with master
unifiedsplit
src/Compile.hs+4−4 src/Elm/Compiler.hs+46−9 src/Parse/Parse.hs+8−8 src/Reporting/Error.hs+12−10 src/Reporting/Result.hs+108 src/Reporting/Task.hs−51 src/Reporting/Warning.hs+20−1 src/Transform/Canonicalize.hs+6−5 src/Validate.hs+21−21
src/Compile.hs+4−4
@@ -7,7 +7,7 @@ import Elm.Utils ((|>))
77import qualified Parse.Helpers as Parse
88import qualified Parse.Parse as Parse
99import qualified Reporting.Error as Error
10−import qualified Reporting.Task as Task
10+import qualified Reporting.Result as Result
1111import qualified Reporting.Warning as Warning
1212import qualified Type.Inference as TI
1313import qualified Transform.Canonicalize as Canonical
@@ -18,7 +18,7 @@ compile
1818 -> String
1919 -> Module.Interfaces
2020 -> String
21− -> Task.Task Warning.Warning Error.Error Module.CanonicalModule
21+ -> Result.Result Warning.Warning Error.Error Module.CanonicalModule
2222
2323compile user projectName interfaces source =
2424 do
@@ -29,7 +29,7 @@ compile user projectName interfaces source =
2929
3030 -- Parse the source code
3131 validModule <-
32− Task.mapError Error.Syntax $
32+ Result.mapError Error.Syntax $
3333 Parse.program needsDefaults (getOpTable interfaces) source
3434
3535 -- Canonicalize all variables, pinning down where they came from.
@@ -38,7 +38,7 @@ compile user projectName interfaces source =
3838
3939 -- Run type inference on the program.
4040 types <-
41− Task.from Error.Type $
41+ Result.from Error.Type $
4242 TI.infer interfaces canonicalModule
4343
4444 -- Add the real list of tyes
src/Elm/Compiler.hs+46−9
@@ -3,6 +3,8 @@
33module Elm.Compiler
44 ( version, rawVersion
55 , parseDependencies, compile
6+ , Error, errorToString, errorToJson
7+ , Warning, warningToString, warningToJson
68 ) where
79
810import Control.Monad.Error.Class (MonadError, throwError)
@@ -16,7 +18,9 @@ import qualified Generate.JavaScript as JS
1618import qualified Parse.Helpers as Help
1719import qualified Parse.Module as Parse
1820import qualified Reporting.Annotation as A
19−import qualified Reporting.Task as Task
21+import qualified Reporting.Error as Error
22+import qualified Reporting.Result as Result
23+import qualified Reporting.Warning as Warning
2024
2125
2226-- VERSION
@@ -57,17 +61,50 @@ compile
5761 -> String
5862 -> String
5963 -> Map.Map PublicModule.Name PublicModule.Interface
60− -> Either String (PublicModule.Interface, String)
64+ -> ([Warning], Either [Error] (PublicModule.Interface, String))
6165compile user packageName source interfaces =
6266 let unwrappedInterfaces =
63− Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces
67+ Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces
6468
65− task =
66− Compile.compile user packageName unwrappedInterfaces source
69+ (Result.Result warnings rawResult) =
70+ Compile.compile user packageName unwrappedInterfaces source
6771 in
68− case Task.run task of
69− (Right modul, _warnings) ->
72+ (,) (map Warning warnings) $
73+ case rawResult of
74+ Result.Ok modul ->
7075 Right (Module.toInterface modul, JS.generate modul)
7176
72− (Left _docs, _warnings) ->
73− Left [error "TODO:compile"]
77+ Result.Err errors ->
78+ Left (map Error errors)
79+
80+
81+-- ERRORS
82+
83+newtype Error = Error (A.Located Error.Error)
84+
85+
86+errorToString :: Error -> String
87+errorToString (Error err) =
88+ Error.toString err
89+
90+
91+errorToJson :: Error -> String
92+errorToJson (Error err) =
93+ Error.toJson err
94+
95+
96+-- WARNINGS
97+
98+newtype Warning = Warning (A.Located Warning.Warning)
99+
100+
101+warningToString :: Warning -> String
102+warningToString (Warning warning) =
103+ Warning.toString warning
104+
105+
106+warningToJson :: Warning -> String
107+warningToJson (Warning warning) =
108+ Warning.toJson warning
109+
110+
src/Parse/Parse.hs+8−8
@@ -14,7 +14,7 @@ import qualified Parse.Module as Module
1414import qualified Parse.Declaration as Decl
1515import qualified Reporting.Region as R
1616import qualified Reporting.Error.Syntax as Error
17−import qualified Reporting.Task as Task
17+import qualified Reporting.Result as Result
1818import qualified Transform.AddDefaultImports as DefaultImports
1919import qualified Validate
2020
@@ -23,7 +23,7 @@ program
2323 :: Bool
2424 -> OpTable
2525 -> String
26− -> Task.Task wrn Error.Error M.ValidModule
26+ -> Result.Result wrn Error.Error M.ValidModule
2727program needsDefaults table src =
2828 do (M.Module names filePath exports imports sourceDecls) <-
2929 parseWithTable table src programParser
@@ -63,7 +63,7 @@ freshDef =
6363
6464-- RUN PARSERS
6565
66−parse :: String -> IParser a -> Task.Task wrn Error.Error a
66+parse :: String -> IParser a -> Result.Result wrn Error.Error a
6767parse source parser =
6868 case iParse parser source of
6969 Right result ->
@@ -73,14 +73,14 @@ parse source parser =
7373 let pos = R.fromSourcePos (Parsec.errorPos err)
7474 msgs = Parsec.errorMessages err
7575 in
76− Task.throw (R.Region pos pos) (Error.Parse msgs)
76+ Result.throw (R.Region pos pos) (Error.Parse msgs)
7777
7878
7979parseWithTable
8080 :: OpTable
8181 -> String
8282 -> IParser a
83− -> Task.Task wrn Error.Error a
83+ -> Result.Result wrn Error.Error a
8484parseWithTable table source parser =
8585 do infixInfoList <- parse source parseFixities
8686
@@ -97,7 +97,7 @@ parseWithTable table source parser =
9797makeInfixTable
9898 :: Map.Map String (Int, D.Assoc)
9999 -> [(String, InfixInfo)]
100− -> Task.Task wrn Error.Error (Map.Map String (Int, D.Assoc))
100+ -> Result.Result wrn Error.Error (Map.Map String (Int, D.Assoc))
101101makeInfixTable table newInfo =
102102 let add (op, info) dict =
103103 Map.insertWith (++) op [info] dict
@@ -112,11 +112,11 @@ makeInfixTable table newInfo =
112112
113113 [InfixInfo region info] ->
114114 if Map.member op table
115− then Task.throw region (Error.InfixDuplicate op)
115+ then Result.throw region (Error.InfixDuplicate op)
116116 else return info
117117
118118 InfixInfo region _ : _ ->
119− Task.throw region (Error.InfixDuplicate op)
119+ Result.throw region (Error.InfixDuplicate op)
120120 in
121121 Map.union table <$> T.sequenceA (Map.mapWithKey check infoTable)
122122
src/Reporting/Error.hs+12−10
@@ -3,11 +3,12 @@ module Reporting.Error where
33
44import Data.Aeson ((.=))
55import qualified Data.Aeson as Json
6+import qualified Data.ByteString.Lazy.Char8 as BS
67
8+import qualified Reporting.Annotation as A
79import qualified Reporting.Error.Canonicalize as Canonicalize
810import qualified Reporting.Error.Syntax as Syntax
911import qualified Reporting.Error.Type as Type
10−import qualified Reporting.Region as R
1112
1213
1314-- ALL POSSIBLE ERRORS
@@ -20,8 +21,8 @@ data Error
2021
2122-- TO STRING
2223
23−toString :: R.Region -> Error -> String
24−toString region err =
24+toString :: A.Located Error -> String
25+toString (A.A region err) =
2526 case err of
2627 Syntax syntaxError ->
2728 Syntax.toString region syntaxError
@@ -35,8 +36,8 @@ toString region err =
3536
3637-- JSON
3738
38−toJson :: R.Region -> Error -> Json.Value
39−toJson region err =
39+toJson :: A.Located Error -> String
40+toJson (A.A region err) =
4041 let json =
4142 case err of
4243 Syntax syntaxError ->
@@ -48,8 +49,9 @@ toJson region err =
4849 Type typeError ->
4950 Type.toJson typeError
5051 in
51− Json.object
52− [ "tag" .= ("error" :: String)
53− , "region" .= region
54− , "error" .= json
55− ]
52+ BS.unpack $ Json.encode $
53+ Json.object
54+ [ "tag" .= ("error" :: String)
55+ , "region" .= region
56+ , "error" .= json
57+ ]
src/Reporting/Result.hsnew file+108
@@ -0,0 +1,108 @@
1+module Reporting.Result where
2+
3+import qualified Control.Applicative as A
4+import qualified Control.Monad as M
5+import Control.Monad.Except (Except, runExcept)
6+
7+import qualified Reporting.Annotation as A
8+import qualified Reporting.Region as R
9+
10+
11+-- TASK
12+
13+data Result warning error result =
14+ Result [A.Located warning] (RawResult [A.Located error] result)
15+
16+data RawResult e a
17+ = Ok a
18+ | Err e
19+
20+
21+-- HELPERS
22+
23+ok :: a -> Result w e a
24+ok value =
25+ Result [] (Ok value)
26+
27+
28+throw :: R.Region -> e -> Result w e a
29+throw region err =
30+ Result [] (Err [A.A region err])
31+
32+
33+throwMany :: [A.Located e] -> Result w e a
34+throwMany errors =
35+ Result [] (Err errors)
36+
37+
38+from :: (e -> e') -> Except [A.Located e] a -> Result w e' a
39+from f except =
40+ case runExcept except of
41+ Right answer ->
42+ ok answer
43+
44+ Left errors ->
45+ throwMany (map (A.map f) errors)
46+
47+
48+mapError :: (e -> e') -> Result w e a -> Result w e' a
49+mapError f (Result warnings rawResult) =
50+ Result warnings $
51+ case rawResult of
52+ Ok v ->
53+ Ok v
54+
55+ Err msgs ->
56+ Err (map (A.map f) msgs)
57+
58+
59+addWarnings :: [A.Located w] -> Result w e a -> Result w e a
60+addWarnings newWarnings (Result warnings rawResult) =
61+ Result (newWarnings ++ warnings) rawResult
62+
63+
64+-- EXTRA FANCY HELPERS
65+
66+instance M.Functor (Result w e) where
67+ fmap func (Result warnings rawResult) =
68+ case rawResult of
69+ Ok a ->
70+ Result warnings (Ok (func a))
71+
72+ Err msgs ->
73+ Result warnings (Err msgs)
74+
75+
76+instance A.Applicative (Result w e) where
77+ pure value =
78+ ok value
79+
80+ (<*>) (Result warnings resultFunc) (Result warnings' resultVal) =
81+ Result (warnings ++ warnings') $
82+ case (resultFunc, resultVal) of
83+ (Ok func, Ok val) ->
84+ Ok (func val)
85+
86+ (Err msgs, Err msgs') ->
87+ Err (msgs ++ msgs')
88+
89+ (Err msgs, _) ->
90+ Err msgs
91+
92+ (_, Err msgs) ->
93+ Err msgs
94+
95+
96+instance M.Monad (Result w e) where
97+ return value =
98+ ok value
99+
100+ (>>=) (Result warnings rawResult) callback =
101+ case rawResult of
102+ Err msg ->
103+ Result warnings (Err msg)
104+
105+ Ok value ->
106+ let (Result warnings' rawResult') = callback value
107+ in
108+ Result (warnings ++ warnings') rawResult'
src/Reporting/Task.hsdeleted−51
@@ -1,51 +0,0 @@
1−module Reporting.Task where
2−
3−import Control.Monad.Except (Except, ExceptT, runExcept, runExceptT, throwError, withExceptT)
4−import qualified Control.Monad.State as State
5−
6−import qualified Reporting.Annotation as A
7−import qualified Reporting.Region as R
8−
9−
10−-- TASK
11−
12−type Task warning error result =
13− ExceptT [A.Located error] (State.State [A.Located warning]) result
14−
15−
16−-- RUN TASKS
17−
18−run :: Task w e a -> (Either [A.Located e] a, [A.Located w])
19−run task =
20− State.runState (runExceptT task) []
21−
22−
23−-- WARNINGS
24−
25−addWarnings :: [A.Located w] -> Task w e ()
26−addWarnings warnings =
27− State.modify (warnings++)
28−
29−
30−-- ERRORS
31−
32−throw :: R.Region -> e -> Task w e a
33−throw region err =
34− throwError [A.A region err]
35−
36−
37−mapError :: (e -> e') -> Task w e a -> Task w e' a
38−mapError f task =
39− withExceptT (map (A.map f)) task
40−
41−
42−from :: (e -> e') -> Except [A.Located e] a -> Task w e' a
43−from f except =
44− case runExcept except of
45− Right answer ->
46− return answer
47−
48− Left errors ->
49− throwError (map (A.map f) errors)
50−
51−
src/Reporting/Warning.hs+20−1
@@ -2,7 +2,26 @@ module Reporting.Warning where
22
33import qualified AST.Module as Module
44
5+import qualified Reporting.Annotation as A
6+
57
68data Warning
79 = UnusedImport Module.Name
8− | MissingTypeAnnotation String
10+ | MissingTypeAnnotation String
11+
12+
13+-- TO STRING
14+
15+toString :: A.Located Warning -> String
16+toString (A.A region warning) =
17+ case warning of
18+ _ -> error "Warning.toString" region
19+
20+
21+-- TO JSON
22+
23+toJson :: A.Located Warning -> String
24+toJson (A.A region warning) =
25+ case warning of
26+ _ -> error "Warning.toJson" region
27+
src/Transform/Canonicalize.hs+6−5
@@ -1,7 +1,6 @@
11module Transform.Canonicalize (module') where
22
33import Control.Applicative ((<$>),(<*>))
4−import Control.Monad.Except (throwError)
54import qualified Data.List as List
65import qualified Data.Map as Map
76import qualified Data.Maybe as Maybe
@@ -22,7 +21,7 @@ import qualified AST.Variable as Var
2221import qualified Reporting.Annotation as A
2322import qualified Reporting.Error as Error
2423import qualified Reporting.Error.Canonicalize as CError
25−import qualified Reporting.Task as Task
24+import qualified Reporting.Result as R
2625import qualified Reporting.Warning as Warning
2726import qualified Transform.Canonicalize.Environment as Env
2827import qualified Transform.Canonicalize.Port as Port
@@ -39,19 +38,21 @@ import qualified Transform.Declaration as Transform
3938module'
4039 :: Module.Interfaces
4140 -> Module.ValidModule
42− -> Task.Task Warning.Warning Error.Error Module.CanonicalModule
41+ -> R.Result Warning.Warning Error.Error Module.CanonicalModule
4342module' interfaces modul@(Module.Module _ _ _ (_, imports) _) =
4443 let (Result.Result uses rawResults) =
4544 moduleHelp interfaces modul
4645
46+ unusedImportWarnings =
47+ Maybe.mapMaybe (warnUnusedImport uses) imports
4748 in
48− do Task.addWarnings (Maybe.mapMaybe (warnUnusedImport uses) imports)
49+ R.addWarnings unusedImportWarnings $
4950 case rawResults of
5051 Result.Ok canonicalModule ->
5152 return canonicalModule
5253
5354 Result.Err msgs ->
54− throwError (map (A.map Error.Canonicalize) msgs)
55+ R.throwMany (map (A.map Error.Canonicalize) msgs)
5556
5657
5758moduleHelp
src/Validate.hs+21−21
@@ -17,14 +17,14 @@ import Elm.Utils ((|>))
1717import qualified Reporting.Annotation as A
1818import qualified Reporting.Error.Syntax as Error
1919import qualified Reporting.Region as R
20−import qualified Reporting.Task as Task
20+import qualified Reporting.Result as Result
2121
2222
2323-- VALIDATE DECLARATIONS
2424
2525declarations
2626 :: [D.SourceDecl]
27− -> Task.Task wrn Error.Error [D.ValidDecl]
27+ -> Result.Result wrn Error.Error [D.ValidDecl]
2828declarations sourceDecls =
2929 do validDecls <- validateDecls sourceDecls
3030 (\_ _ -> validDecls)
@@ -34,7 +34,7 @@ declarations sourceDecls =
3434
3535validateDecls
3636 :: [D.SourceDecl]
37− -> Task.Task wrn Error.Error [D.ValidDecl]
37+ -> Result.Result wrn Error.Error [D.ValidDecl]
3838validateDecls sourceDecls =
3939 case sourceDecls of
4040 [] ->
@@ -47,7 +47,7 @@ validateDecls sourceDecls =
4747validateDeclsHelp
4848 :: D.SourceDecl
4949 -> [D.SourceDecl]
50− -> Task.Task wrn Error.Error [D.ValidDecl]
50+ -> Result.Result wrn Error.Error [D.ValidDecl]
5151validateDeclsHelp (A.A region decl) decls =
5252 let addRest validDecl =
5353 (:) (A.A region validDecl) <$> validateDecls decls
@@ -74,7 +74,7 @@ validateDeclsHelp (A.A region decl) decls =
7474defHelp
7575 :: Source.Def
7676 -> [D.SourceDecl]
77− -> Task.Task wrn Error.Error [D.ValidDecl]
77+ -> Result.Result wrn Error.Error [D.ValidDecl]
7878defHelp (A.A region def) decls =
7979 let addRest def' rest =
8080 (:) (A.A region (D.Definition def')) <$> validateDecls rest
@@ -94,7 +94,7 @@ defHelp (A.A region def) decls =
9494 addRest def' rest
9595
9696 _ ->
97− Task.throw region (Error.TypeWithoutDefinition name)
97+ Result.throw region (Error.TypeWithoutDefinition name)
9898
9999
100100-- VALIDATE PORTS IN DECLARATIONS
@@ -103,14 +103,14 @@ portHelp
103103 :: R.Region
104104 -> D.SourcePort
105105 -> [D.SourceDecl]
106− -> Task.Task wrn Error.Error [D.ValidDecl]
106+ -> Result.Result wrn Error.Error [D.ValidDecl]
107107portHelp region port decls =
108108 let addRest port' rest =
109109 (:) (A.A region (D.Port port')) <$> validateDecls rest
110110 in
111111 case port of
112112 D.PortDefinition name _ ->
113− Task.throw region (Error.PortWithoutAnnotation name)
113+ Result.throw region (Error.PortWithoutAnnotation name)
114114
115115 D.PortAnnotation name tipe ->
116116 case decls of
@@ -126,7 +126,7 @@ portHelp region port decls =
126126
127127-- VALIDATE DEFINITIONS
128128
129−definitions :: [Source.Def] -> Task.Task wrn Error.Error [Valid.Def]
129+definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
130130definitions sourceDefs =
131131 do validDefs <- definitionsHelp sourceDefs
132132 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
@@ -134,7 +134,7 @@ definitions sourceDefs =
134134 return validDefs
135135
136136
137−definitionsHelp :: [Source.Def] -> Task.Task wrn Error.Error [Valid.Def]
137+definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
138138definitionsHelp sourceDefs =
139139 case sourceDefs of
140140 [] ->
@@ -154,12 +154,12 @@ definitionsHelp sourceDefs =
154154 (:) def <$> definitionsHelp rest'
155155
156156 _ ->
157− Task.throw region (Error.TypeWithoutDefinition name)
157+ Result.throw region (Error.TypeWithoutDefinition name)
158158
159159
160160-- VALIDATE EXPRESSIONS
161161
162−expression :: Source.Expr -> Task.Task wrn Error.Error Valid.Expr
162+expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
163163expression (A.A ann sourceExpression) =
164164 A.A ann <$>
165165 case sourceExpression of
@@ -250,14 +250,14 @@ expression (A.A ann sourceExpression) =
250250 return (Task name expr' tipe)
251251
252252
253−second :: (a, Source.Expr) -> Task.Task wrn Error.Error (a, Valid.Expr)
253+second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
254254second (value, expr) =
255255 (,) value <$> expression expr
256256
257257
258258both
259259 :: (Source.Expr, Source.Expr)
260− -> Task.Task wrn Error.Error (Valid.Expr, Valid.Expr)
260+ -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
261261both (expr1, expr2) =
262262 (,) <$> expression expr1 <*> expression expr2
263263
@@ -267,7 +267,7 @@ both (expr1, expr2) =
267267detectDuplicates
268268 :: (String -> Error.Error)
269269 -> [A.Located String]
270− -> Task.Task wrn Error.Error ()
270+ -> Result.Result wrn Error.Error ()
271271detectDuplicates tag names =
272272 let add (A.A region name) dict =
273273 Map.insertWith (++) name [region] dict
@@ -278,7 +278,7 @@ detectDuplicates tag names =
278278 check (name, regions) =
279279 case regions of
280280 _ : region : _ ->
281− Task.throw region (tag name)
281+ Result.throw region (tag name)
282282
283283 _ ->
284284 return ()
@@ -288,13 +288,13 @@ detectDuplicates tag names =
288288
289289defDuplicates
290290 :: [Pattern.RawPattern]
291− -> Task.Task wrn Error.Error ()
291+ -> Result.Result wrn Error.Error ()
292292defDuplicates patterns =
293293 concatMap Pattern.boundVars patterns
294294 |> detectDuplicates Error.DuplicateDefinition
295295
296296
297−declDuplicates :: [D.ValidDecl] -> Task.Task wrn Error.Error ()
297+declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
298298declDuplicates decls =
299299 let (valueLists, typeLists) = unzip (map extractValues decls)
300300 in
@@ -339,7 +339,7 @@ extractValues (A.A region decl) =
339339
340340-- UNBOUND TYPE VARIABLES
341341
342−checkDecl :: D.ValidDecl -> Task.Task wrn Error.Error ()
342+checkDecl :: D.ValidDecl -> Result.Result wrn Error.Error ()
343343checkDecl (A.A _ decl) =
344344 case decl of
345345 D.Definition _ ->
@@ -358,14 +358,14 @@ checkDecl (A.A _ decl) =
358358 return ()
359359
360360
361−checkTypeVars :: String -> [String] -> Type.Raw -> Task.Task wrn Error.Error ()
361+checkTypeVars :: String -> [String] -> Type.Raw -> Result.Result wrn Error.Error ()
362362checkTypeVars name boundVars tipe =
363363 let bounds = Set.fromList boundVars
364364
365365 check (A.A region free) =
366366 if Set.member free bounds
367367 then return ()
368− else Task.throw region (Error.UnboundTypeVar name free)
368+ else Result.throw region (Error.UnboundTypeVar name free)
369369 in
370370 F.traverse_ check (freeVars tipe)
371371