git.iko.soy/elk
on master help sign in
Use the same Result type everywhere

Also switch from Lists to Bags for values that will be accumulated with the Result type

commit94ebc2dc56827b865f77b447f4319ec5fdcd2feb authorEvan Czaplicki <info@elm-lang.org> dateMon 28 Mar 2016, 17:59 (11 years ago) parent0e50803
16 files changed+464−452
compare with master
unifiedsplit
elm-compiler.cabal+1−1 src/Canonicalize.hs+81−82 src/Canonicalize/Effects.hs+11−14 src/Canonicalize/Result.hs−117 src/Canonicalize/Setup.hs+32−33 src/Canonicalize/Type.hs+13−16 src/Canonicalize/Variable.hs+47−23 src/Compile.hs+10−5 src/Docs/Check.hs+4−2 src/Elm/Compiler.hs+14−24 src/Nitpick/PatternMatches.hs+9−16 src/Nitpick/TopLevelTypes.hs+8−7 src/Parse/Parse.hs+4−12 src/Reporting/Bag.hs+101 src/Reporting/Result.hs+97−57 src/Validate.hs+32−43
elm-compiler.cabal+1−1
@@ -65,7 +65,6 @@ Library
6565 Canonicalize.Body,
6666 Canonicalize.Effects,
6767 Canonicalize.Environment,
68− Canonicalize.Result,
6968 Canonicalize.Setup,
7069 Canonicalize.Sort,
7170 Canonicalize.Type,
@@ -102,6 +101,7 @@ Library
102101 Parse.Pattern,
103102 Parse.Type,
104103 Reporting.Annotation,
104+ Reporting.Bag,
105105 Reporting.Error,
106106 Reporting.Error.Canonicalize,
107107 Reporting.Error.Docs,
src/Canonicalize.hs+81−82
@@ -1,10 +1,10 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Canonicalize (module') where
23
34import qualified Data.List as List
45import qualified Data.Map as Map
56import qualified Data.Maybe as Maybe
67import qualified Data.Set as Set
7−import qualified Data.Traversable as T
88import qualified Data.Foldable as T
99
1010import AST.Expression.General (Expr'(..))
@@ -18,24 +18,28 @@ import qualified AST.Module.Name as ModuleName
1818import qualified AST.Pattern as P
1919import qualified AST.Type as Type
2020import qualified AST.Variable as Var
21+import qualified Canonicalize.Body as Body
22+import qualified Canonicalize.Effects as Effects
23+import qualified Canonicalize.Environment as Env
24+import qualified Canonicalize.Setup as Setup
25+import qualified Canonicalize.Type as Canon
26+import qualified Canonicalize.Variable as Canon
2127import qualified Docs.Centralize as Docs
2228import qualified Reporting.Annotation as A
2329import qualified Reporting.Error as Error
2430import qualified Reporting.Error.Canonicalize as CError
2531import qualified Reporting.Error.Helpers as ErrorHelp
2632import qualified Reporting.Region as Region
27−import qualified Reporting.Result as R
33+import qualified Reporting.Render.Type as RenderType
34+import qualified Reporting.Result as Result
2835import qualified Reporting.Warning as Warning
29−import qualified Canonicalize.Body as Body
30−import qualified Canonicalize.Effects as Effects
31−import qualified Canonicalize.Environment as Env
32−import qualified Canonicalize.Result as Result
33−import qualified Canonicalize.Setup as Setup
34−import qualified Canonicalize.Type as Canonicalize
35−import qualified Canonicalize.Variable as Canonicalize
3636
3737
3838
39+type Result a =
40+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a
41+
42+
3943-- MODULES
4044
4145
@@ -43,29 +47,29 @@ module'
4347 :: [ModuleName.Canonical]
4448 -> Module.Interfaces
4549 -> Module.Valid
46− -> R.Result Warning.Warning Error.Error Module.Canonical
47−module' canonicalImports interfaces modul =
50+ -> Result Module.Canonical
51+module' allCanonicalImports interfaces modul =
4852 let
4953 (Module.Valid docs exports imports decls effects) =
5054 Module.info modul
5155
5256 importDict =
53− canonicalImports
57+ allCanonicalImports
5458 |> map (\cName -> (ModuleName._module cName, cName))
5559 |> Map.fromList
5660
57− (Result.Result uses rawResults) =
58− Setup.environment importDict interfaces modul
59− `Result.andThen` \env ->
61+ (Result.Result uses warnings rawResults) =
62+ do env <- Setup.environment importDict interfaces modul
6063
61− (,,,) env
62− <$> resolveExports (Effects.toValues effects ++ declsToValues decls) exports
63− <*> canonicalizeDecls env decls
64− <*> Effects.canonicalize env effects
64+ (,,,) env
65+ <$> resolveExports (Effects.toValues effects ++ declsToValues decls) exports
66+ <*> canonicalizeDecls env decls
67+ <*> Effects.canonicalize env effects
6568 in
6669 case rawResults of
67− Result.Err msgs ->
68− R.throwMany (map (A.map Error.Canonicalize) msgs)
70+ Result.Err errors ->
71+ Result.mapError Error.Canonicalize $
72+ Result.Result Result.None warnings (Result.Err errors)
6973
7074 Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->
7175 let
@@ -81,9 +85,9 @@ module' canonicalImports interfaces modul =
8185 program =
8286 Body.flatten (Module.name modul) canonicalDecls canonicalEffects
8387 in
84− R.addDealiaser (Env.toDealiaser env) $
85− do canonicalImports <- filterImports uses imports
86− return $ modul {
88+ do canonicalImports <- filterImports uses imports
89+ Result.accumulate (Result.One (Env.toDealiaser env)) $
90+ modul {
8791 Module.info =
8892 Module.Info
8993 { Module.docs = centralizedDocs
@@ -96,7 +100,7 @@ module' canonicalImports interfaces modul =
96100 , Module.unions = Map.fromList (map typeToPair unions)
97101 , Module.effects = canonicalEffects
98102 }
99− }
103+ }
100104
101105
102106
@@ -106,7 +110,7 @@ module' canonicalImports interfaces modul =
106110filterImports
107111 :: Set.Set ModuleName.Raw
108112 -> ([Module.DefaultImport], [Module.UserImport])
109− -> R.Result Warning.Warning e [ModuleName.Raw]
113+ -> Result [ModuleName.Raw]
110114filterImports uses (defaults, imports) =
111115 let
112116 checkImport (A.A region (name, _method)) =
@@ -114,24 +118,28 @@ filterImports uses (defaults, imports) =
114118 return (Just name)
115119
116120 else
117− do R.warn region (Warning.UnusedImport name)
118− return Nothing
121+ Result.warn region (Warning.UnusedImport name) Nothing
119122 in
120123 do reducedImports <-
121− Maybe.catMaybes <$> T.traverse checkImport imports
124+ Maybe.catMaybes <$> traverse checkImport imports
122125
123126 return $
124127 Set.toList (Set.fromList (map fst defaults ++ reducedImports))
125128
126129
127130
131+-------- CANONICALIZATION --------
132+
133+
134+type CResult a =
135+ Canon.Result a
136+
137+
138+
128139-- EXPORTS
129140
130141
131−resolveExports
132− :: [Var.Value]
133− -> Var.Listing (A.Located Var.Value)
134− -> Result.ResultErr [Var.Value]
142+resolveExports :: [Var.Value] -> Var.Listing (A.Located Var.Value) -> CResult [Var.Value]
135143resolveExports fullList (Var.Listing partialList open) =
136144 if open then
137145 Result.ok fullList
@@ -148,17 +156,13 @@ resolveExports fullList (Var.Listing partialList open) =
148156 map fst allAdts
149157 in
150158 (\xs ys zs _ -> xs ++ ys ++ zs)
151− <$> T.traverse (getValueExport allValues (Set.fromList allValues)) values
152− <*> (concat <$> T.traverse (getAliasExport allValues allAliases adtTypes) aliases)
153− <*> T.traverse (getAdtExport allAdts adtTypes) adts
159+ <$> traverse (getValueExport allValues (Set.fromList allValues)) values
160+ <*> (concat <$> traverse (getAliasExport allValues allAliases adtTypes) aliases)
161+ <*> traverse (getAdtExport allAdts adtTypes) adts
154162 <*> allUnique partialList
155163
156164
157−getValueExport
158− :: [String]
159− -> Set.Set String
160− -> A.Located String
161− -> Result.ResultErr Var.Value
165+getValueExport :: [String] -> Set.Set String -> A.Located String -> CResult Var.Value
162166getValueExport allValues allValuesSet (A.A region name) =
163167 if Set.member name allValuesSet then
164168 Result.ok (Var.Value name)
@@ -166,12 +170,7 @@ getValueExport allValues allValuesSet (A.A region name) =
166170 manyNotFound region [name] allValues
167171
168172
169−getAliasExport
170− :: [String]
171− -> [String]
172− -> [String]
173− -> A.Located String
174− -> Result.ResultErr [Var.Value]
173+getAliasExport :: [String] -> [String] -> [String] -> A.Located String -> CResult [Var.Value]
175174getAliasExport allValues allAliases adtTypes (A.A region alias) =
176175 if alias `elem` allAliases then
177176
@@ -191,7 +190,7 @@ getAdtExport
191190 :: [(String, Var.Listing String)]
192191 -> [String]
193192 -> A.Located (String, Var.Listing String)
194− -> Result.ResultErr Var.Value
193+ -> CResult Var.Value
195194getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =
196195 case List.lookup name allAdts of
197196 Nothing ->
@@ -208,9 +207,9 @@ getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =
208207 manyNotFound region unfoundCtors allCtors
209208
210209
211−manyNotFound :: Region.Region -> [String] -> [String] -> Result.ResultErr a
210+manyNotFound :: Region.Region -> [String] -> [String] -> CResult a
212211manyNotFound region nameList possibilities =
213− Result.errors (map (notFound region possibilities) nameList)
212+ Result.throwMany (map (notFound region possibilities) nameList)
214213
215214
216215notFound :: Region.Region -> [String] -> String -> A.Located CError.Error
@@ -219,7 +218,7 @@ notFound region possibilities name =
219218 ErrorHelp.nearbyNames id name possibilities
220219
221220
222−allUnique :: [A.Located Var.Value] -> Result.ResultErr ()
221+allUnique :: [A.Located Var.Value] -> CResult ()
223222allUnique statedExports =
224223 let
225224 valueToString value =
@@ -234,12 +233,12 @@ allUnique statedExports =
234233 isUnique value allRegions =
235234 case allRegions of
236235 region : _ : _ ->
237− Result.err (A.A region (CError.DuplicateExport (valueToString value)))
236+ Result.throw region (CError.DuplicateExport (valueToString value))
238237
239238 _ ->
240239 Result.ok ()
241240 in
242− T.traverse_ id (Map.mapWithKey isUnique locations)
241+ T.sequenceA_ (Map.mapWithKey isUnique locations)
243242
244243
245244
@@ -319,46 +318,46 @@ splitLocatedValue (A.A region value) =
319318-- DECLARATIONS
320319
321320
322−canonicalizeDecls :: Env.Environment -> D.Valid -> Result.ResultErr D.Canonical
321+canonicalizeDecls :: Env.Environment -> D.Valid -> CResult D.Canonical
323322canonicalizeDecls env (D.Decls defs unions aliases infixes) =
324323 let
325− traverse canEntry entries =
326− T.traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
324+ annTraverse canEntry entries =
325+ traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
327326
328327 canonicalizeDef (Valid.Def pat expr typ) =
329328 Canonical.Def Canonical.dummyFacts
330329 <$> canonicalizePattern env pat
331330 <*> canonicalizeExpr env expr
332− <*> T.traverse (canonicalizeRegionType env) typ
331+ <*> traverse (canonicalizeRegionType env) typ
333332
334333 canonicalizeArgs (ctor, args) =
335− (,) ctor <$> T.traverse (Canonicalize.tipe env) args
334+ (,) ctor <$> traverse (Canon.tipe env) args
336335
337336 canonicalizeUnion (D.Type name tvars ctors) =
338− D.Type name tvars <$> T.traverse canonicalizeArgs ctors
337+ D.Type name tvars <$> traverse canonicalizeArgs ctors
339338
340339 canonicalizeAlias (D.Type name tvars alias) =
341− D.Type name tvars <$> Canonicalize.tipe env alias
340+ D.Type name tvars <$> Canon.tipe env alias
342341 in
343342 D.Decls
344− <$> traverse canonicalizeDef defs
345− <*> traverse canonicalizeUnion unions
346− <*> traverse canonicalizeAlias aliases
343+ <$> annTraverse canonicalizeDef defs
344+ <*> annTraverse canonicalizeUnion unions
345+ <*> annTraverse canonicalizeAlias aliases
347346 <*> pure infixes
348347
349348
350349canonicalizeRegionType
351350 :: Env.Environment
352351 -> Type.Raw
353− -> Result.ResultErr (A.Located Type.Canonical)
352+ -> CResult (A.Located Type.Canonical)
354353canonicalizeRegionType env typ@(A.A region _) =
355− A.A region <$> Canonicalize.tipe env typ
354+ A.A region <$> Canon.tipe env typ
356355
357356
358357canonicalizeExpr
359358 :: Env.Environment
360359 -> Valid.Expr
361− -> Result.ResultErr Canonical.Expr
360+ -> CResult Canonical.Expr
362361canonicalizeExpr env (A.A region validExpr) =
363362 let go = canonicalizeExpr env
364363 in
@@ -376,15 +375,15 @@ canonicalizeExpr env (A.A region validExpr) =
376375 Update record fields ->
377376 Update
378377 <$> go record
379− <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
378+ <*> traverse (\(field,expr) -> (,) field <$> go expr) fields
380379
381380 Record fields ->
382381 Record
383− <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
382+ <$> traverse (\(field,expr) -> (,) field <$> go expr) fields
384383
385384 Binop (Var.Raw op) leftExpr rightExpr ->
386385 Binop
387− <$> Canonicalize.variable region env op
386+ <$> Canon.variable region env op
388387 <*> go leftExpr
389388 <*> go rightExpr
390389
@@ -400,14 +399,14 @@ canonicalizeExpr env (A.A region validExpr) =
400399
401400 If branches finally ->
402401 If
403− <$> T.traverse go' branches
402+ <$> traverse go' branches
404403 <*> go finally
405404 where
406405 go' (condition, branch) =
407406 (,) <$> go condition <*> go branch
408407
409− Let defs body ->
410− Let <$> T.traverse rename' defs <*> canonicalizeExpr env' body
408+ Let defs expr ->
409+ Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
411410 where
412411 env' =
413412 foldr Env.addPattern env (map Valid.getPattern defs)
@@ -416,19 +415,19 @@ canonicalizeExpr env (A.A region validExpr) =
416415 Canonical.Def Canonical.dummyFacts
417416 <$> canonicalizePattern env' p
418417 <*> canonicalizeExpr env' body
419− <*> T.traverse (canonicalizeRegionType env') mtipe
418+ <*> traverse (canonicalizeRegionType env') mtipe
420419
421420 Var (Var.Raw x) ->
422− Var <$> Canonicalize.variable region env x
421+ Var <$> Canon.variable region env x
423422
424423 Data name exprs ->
425− Data name <$> T.traverse go exprs
424+ Data name <$> traverse go exprs
426425
427426 ExplicitList exprs ->
428− ExplicitList <$> T.traverse go exprs
427+ ExplicitList <$> traverse go exprs
429428
430429 Case expr cases ->
431− Case <$> go expr <*> T.traverse branch cases
430+ Case <$> go expr <*> traverse branch cases
432431 where
433432 branch (ptrn, brnch) =
434433 (,)
@@ -442,10 +441,10 @@ canonicalizeExpr env (A.A region validExpr) =
442441 Result.ok (Sub moduleName)
443442
444443 ForeignCmd name tipe ->
445− ForeignCmd name <$> Canonicalize.tipe env tipe
444+ ForeignCmd name <$> Canon.tipe env tipe
446445
447446 ForeignSub name tipe ->
448− ForeignSub name <$> Canonicalize.tipe env tipe
447+ ForeignSub name <$> Canon.tipe env tipe
449448
450449 SaveEnv moduleName effects ->
451450 Result.ok (SaveEnv moduleName effects)
@@ -454,7 +453,7 @@ canonicalizeExpr env (A.A region validExpr) =
454453 Result.ok (GLShader uid src tipe)
455454
456455
457−canonicalizePattern :: Env.Environment -> P.Raw -> Result.ResultErr P.Canonical
456+canonicalizePattern :: Env.Environment -> P.Raw -> CResult P.Canonical
458457canonicalizePattern env (A.A region ptrn) =
459458 A.A region <$>
460459 case ptrn of
@@ -475,5 +474,5 @@ canonicalizePattern env (A.A region ptrn) =
475474
476475 P.Data (Var.Raw name) patterns ->
477476 P.Data
478− <$> Canonicalize.pvar region env name (length patterns)
479− <*> T.traverse (canonicalizePattern env) patterns
477+ <$> Canon.pvar region env name (length patterns)
478+ <*> traverse (canonicalizePattern env) patterns
src/Canonicalize/Effects.hs+11−14
@@ -9,9 +9,10 @@ import qualified AST.Variable as Var
99import qualified Reporting.Annotation as A
1010import qualified Reporting.Error.Canonicalize as Error
1111import qualified Reporting.Region as R
12+import qualified Reporting.Result as Result
1213import qualified Canonicalize.Environment as Env
13−import qualified Canonicalize.Result as Result
1414import qualified Canonicalize.Type as Canonicalize
15+import Canonicalize.Variable (Result)
1516
1617
1718
@@ -35,7 +36,7 @@ toValues effects =
3536-- CANONICALIZE
3637
3738
38−canonicalize :: Env.Environment -> Effects.Raw -> Result.ResultErr Effects.Canonical
39+canonicalize :: Env.Environment -> Effects.Raw -> Result Effects.Canonical
3940canonicalize env effects =
4041 case effects of
4142 Effects.None ->
@@ -51,18 +52,14 @@ canonicalize env effects =
5152canonicalizeRawForeign
5253 :: Env.Environment
5354 -> A.Commented Effects.ForeignRaw
54− -> Result.ResultErr (A.Commented Effects.ForeignCanonical)
55+ -> Result (A.Commented Effects.ForeignCanonical)
5556canonicalizeRawForeign env (A.A ann (Effects.ForeignRaw name rawType)) =
56− Canonicalize.tipe env rawType
57− `Result.andThen` \tipe ->
57+ do tipe <- Canonicalize.tipe env rawType
58+ kind <- figureOutKind (fst ann) name tipe
59+ Result.ok (A.A ann (Effects.ForeignCanonical name kind tipe))
5860
59− figureOutKind (fst ann) name tipe
60− `Result.andThen` \kind ->
6161
62− Result.ok (A.A ann (Effects.ForeignCanonical name kind tipe))
63−
64−
65−figureOutKind :: R.Region -> String -> T.Canonical -> Result.ResultErr Effects.Kind
62+figureOutKind :: R.Region -> String -> T.Canonical -> Result Effects.Kind
6663figureOutKind region name rootType =
6764 case T.deepDealias rootType of
6865 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
@@ -76,7 +73,7 @@ figureOutKind region name rootType =
7673 <$> checkForeignType region name "subscription" incomingType
7774
7875 _ ->
79− Result.err (A.A region (error "TODO - bad overall type"))
76+ Result.throw region (error "TODO - bad overall type")
8077
8178
8279
@@ -86,11 +83,11 @@ figureOutKind region name rootType =
8683--
8784-- Note: assumes that deepDealias has been called on the incoming type.
8885--
89−checkForeignType :: R.Region -> String -> String -> T.Canonical -> Result.ResultErr ()
86+checkForeignType :: R.Region -> String -> String -> T.Canonical -> Result ()
9087checkForeignType region name kind tipe =
9188 let
9289 throwError maybeMessage =
93− Result.err $ A.A region $
90+ Result.throw region $
9491 Error.foreign name kind tipe maybeMessage
9592
9693 check subType =
src/Canonicalize/Result.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Result where
3−
4−import Prelude hiding (foldl)
5−import qualified Control.Applicative as A
6−import qualified Data.Functor as F
7−import qualified Data.Set as Set
8−
9−import qualified AST.Module.Name as ModuleName
10−import qualified AST.Variable as Var
11−import qualified Reporting.Annotation as A
12−import qualified Reporting.Error.Canonicalize as Error
13−
14−
15−type ResultErr a = Result (A.Located Error.Error) a
16−
17−
18−data Result err a =
19− Result (Set.Set ModuleName.Raw) (RawResult err a)
20−
21−
22−data RawResult err a
23− = Ok a
24− | Err [err]
25−
26−
27−-- RESULT HELPERS
28−
29−ok :: a -> Result e a
30−ok value =
31− Result Set.empty (Ok value)
32−
33−
34−err :: e -> Result e a
35−err msg =
36− errors [msg]
37−
38−
39−errors :: [e] -> Result e a
40−errors msgs =
41− Result Set.empty (Err msgs)
42−
43−
44−foldl :: (a -> b -> Result e b) -> b -> [a] -> Result e b
45−foldl f acc list =
46− case list of
47− [] ->
48− ok acc
49−
50− x:xs ->
51− f x acc `andThen` (\acc' -> foldl f acc' xs)
52−
53−
54−andThen :: Result e a -> (a -> Result e b) -> Result e b
55−andThen (Result uses rawResult) callback =
56− case rawResult of
57− Err msg ->
58− Result uses (Err msg)
59−
60− Ok value ->
61− let (Result uses' rawResult') = callback value
62− in
63− Result (Set.union uses uses') rawResult'
64−
65−
66−instance F.Functor (Result e) where
67− fmap func (Result uses result) =
68− case result of
69− Ok a ->
70− Result uses (Ok (func a))
71−
72− Err msgs ->
73− Result uses (Err msgs)
74−
75−
76−instance A.Applicative (Result e) where
77− pure value =
78− ok value
79−
80− (<*>) (Result uses resultFunc) (Result uses' resultVal) =
81− Result (Set.union uses uses') $
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−-- TRACK USES OF IMPORTS
97−
98−addModule :: ModuleName.Raw -> Result e a -> Result e a
99−addModule home (Result uses result) =
100− Result (Set.insert home uses) result
101−
102−
103−var' :: (a -> Var.Canonical) -> a -> Result e a
104−var' toVar value =
105− case toVar value of
106− Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->
107− Result (Set.singleton moduleName) (Ok value)
108−
109− Var.Canonical _ _ ->
110− ok value
111−
112−
113−var :: Var.Canonical -> Result e Var.Canonical
114−var variable =
115− var' id variable
116−
117−
src/Canonicalize/Setup.hs+32−33
@@ -2,6 +2,7 @@
22module Canonicalize.Setup (environment) where
33
44import Control.Arrow (second)
5+import Control.Monad (foldM)
56import qualified Data.Graph as Graph
67import qualified Data.Map as Map
78import qualified Data.Maybe as Maybe
@@ -20,9 +21,10 @@ import qualified Reporting.Annotation as A
2021import qualified Reporting.Error.Canonicalize as Error
2122import qualified Reporting.Error.Helpers as Error
2223import qualified Reporting.Region as R
24+import qualified Reporting.Result as Result
2325import qualified Canonicalize.Environment as Env
24−import qualified Canonicalize.Result as Result
2526import qualified Canonicalize.Type as Canonicalize
27+import Canonicalize.Variable (Result)
2628
2729
2830
@@ -30,7 +32,7 @@ environment
3032 :: Map.Map ModuleName.Raw ModuleName.Canonical
3133 -> Module.Interfaces
3234 -> Module.Valid
33− -> Result.ResultErr Env.Environment
35+ -> Result Env.Environment
3436environment importDict interfaces (Module.Module name _ info) =
3537 let
3638 (Module.Valid _ _ (defaults, imports) decls effects) =
@@ -53,8 +55,8 @@ environment importDict interfaces (Module.Module name _ info) =
5355 name
5456 (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))
5557 in
56− (createEnv <$> getImportPatches)
57− `Result.andThen` addTypeAliases name typeAliasNodes
58+ do env <- createEnv <$> getImportPatches
59+ addTypeAliases name typeAliasNodes env
5860
5961
6062
@@ -65,7 +67,7 @@ importToPatches
6567 :: Map.Map ModuleName.Raw ModuleName.Canonical
6668 -> Module.Interfaces
6769 -> A.Located (ModuleName.Raw, Module.ImportMethod)
68− -> Result.ResultErr [Env.Patch]
70+ -> Result [Env.Patch]
6971importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =
7072 let
7173 maybeInterface =
@@ -84,8 +86,7 @@ importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =
8486 |> map ModuleName._module
8587 |> Error.nearbyNames ModuleName.toString rawImportName
8688 |> Error.moduleNotFound rawImportName
87− |> A.A region
88− |> Result.err
89+ |> Result.throw region
8990
9091 Just (importName, interface) ->
9192 let
@@ -156,7 +157,7 @@ valueToPatches
156157 -> ModuleName.Canonical
157158 -> Module.Interface
158159 -> Var.Value
159− -> Result.ResultErr [Env.Patch]
160+ -> Result [Env.Patch]
160161valueToPatches region moduleName interface value =
161162 let
162163 patch mkPatch x =
@@ -170,8 +171,7 @@ valueToPatches region moduleName interface value =
170171 |> getNames
171172 |> Error.nearbyNames id x
172173 |> Error.valueNotFound (ModuleName._module moduleName) x
173− |> A.A region
174− |> Result.err
174+ |> Result.throw region
175175 in
176176 case value of
177177 Var.Value x ->
@@ -184,13 +184,16 @@ valueToPatches region moduleName interface value =
184184 Var.Alias x ->
185185 case Map.lookup x (Module.iAliases interface) of
186186 Just (tvars, t) ->
187− let alias =
188− Env.Alias x (Var.fromModule moduleName x, tvars, t)
187+ let
188+ alias =
189+ Env.Alias x (Var.fromModule moduleName x, tvars, t)
189190 in
190− Result.ok $
191− if Map.member x (Module.iTypes interface)
192− then [alias, patch Env.Value x]
193− else [alias]
191+ Result.ok $
192+ if Map.member x (Module.iTypes interface) then
193+ [alias, patch Env.Value x]
194+
195+ else
196+ [alias]
194197
195198 Nothing ->
196199 case Map.lookup x (Module.iUnions interface) of
@@ -211,9 +214,11 @@ valueToPatches region moduleName interface value =
211214
212215 Just (_tvars, realCtors) ->
213216 patches <$>
214− if open
215− then Result.ok realCtorList
216− else Trav.traverse ctorExists givenCtorNames
217+ if open then
218+ Result.ok realCtorList
219+
220+ else
221+ Trav.traverse ctorExists givenCtorNames
217222 where
218223 realCtorList =
219224 map (second length) realCtors
@@ -225,6 +230,7 @@ valueToPatches region moduleName interface value =
225230 case Map.lookup givenCtorName realCtorDict of
226231 Just numArgs ->
227232 Result.ok (givenCtorName, numArgs)
233+
228234 Nothing ->
229235 notFound (const (map fst realCtors)) givenCtorName
230236
@@ -264,24 +270,17 @@ node region name tvars alias =
264270 maybe [] edges ext ++ concatMap (edges . snd) fs
265271
266272
267−addTypeAliases
268− :: ModuleName.Canonical
269− -> [Node]
270− -> Env.Environment
271− -> Result.ResultErr Env.Environment
273+addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Environment -> Result Env.Environment
272274addTypeAliases moduleName typeAliasNodes initialEnv =
273− Result.foldl
274− (addTypeAlias moduleName)
275− initialEnv
276− (Graph.stronglyConnComp typeAliasNodes)
275+ foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)
277276
278277
279278addTypeAlias
280279 :: ModuleName.Canonical
281− -> Graph.SCC (R.Region, String, [String], Type.Raw)
282280 -> Env.Environment
283− -> Result.ResultErr Env.Environment
284−addTypeAlias moduleName scc env =
281+ -> Graph.SCC (R.Region, String, [String], Type.Raw)
282+ -> Result Env.Environment
283+addTypeAlias moduleName env scc =
285284 case scc of
286285 Graph.AcyclicSCC (_, name, tvars, alias) ->
287286 addToEnv <$> Canonicalize.tipe env alias
@@ -296,10 +295,10 @@ addTypeAlias moduleName scc env =
296295 Result.ok env
297296
298297 Graph.CyclicSCC [(region, name, tvars, alias)] ->
299− Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))
298+ Result.throw region (Error.Alias (Error.SelfRecursive name tvars alias))
300299
301300 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
302− Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
301+ Result.throw region (Error.Alias (Error.MutuallyRecursive aliases))
303302
304303
305304
src/Canonicalize/Type.hs+13−16
@@ -9,15 +9,13 @@ import qualified AST.Variable as Var
99import qualified Reporting.Annotation as A
1010import qualified Reporting.Error.Canonicalize as Error
1111import qualified Reporting.Region as R
12+import qualified Reporting.Result as Result
1213import qualified Canonicalize.Environment as Env
13−import qualified Canonicalize.Result as Result
1414import qualified Canonicalize.Variable as Canonicalize
15+import Canonicalize.Variable (Result)
1516
1617
17−tipe
18− :: Env.Environment
19− -> T.Raw
20− -> Result.ResultErr T.Canonical
18+tipe :: Env.Environment -> T.Raw -> Result T.Canonical
2119tipe env annType@(A.A _ typ) =
2220 let
2321 go =
@@ -43,16 +41,11 @@ tipe env annType@(A.A _ typ) =
4341 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
4442
4543
46−canonicalizeApp
47− :: Env.Environment
48− -> T.Raw
49− -> [T.Raw]
50− -> Result.ResultErr T.Canonical
44+canonicalizeApp :: Env.Environment -> T.Raw -> [T.Raw] -> Result T.Canonical
5145canonicalizeApp env annFunc@(A.A region func) args =
5246 case func of
5347 T.RType (Var.Raw rawName) ->
54− Canonicalize.tvar region env rawName
55− `Result.andThen` canonicalizeWithTvar
48+ canonicalizeWithTvar =<< Canonicalize.tvar region env rawName
5649
5750 _ ->
5851 T.App
@@ -69,6 +62,7 @@ canonicalizeApp env annFunc@(A.A region func) args =
6962 case args of
7063 [] ->
7164 Result.ok (T.Type name)
65+
7266 _ ->
7367 T.App (T.Type name) <$> Trav.traverse (tipe env) args
7468
@@ -78,17 +72,20 @@ canonicalizeAlias
7872 -> Env.Environment
7973 -> (Var.Canonical, [String], T.Canonical)
8074 -> [T.Raw]
81− -> Result.ResultErr T.Canonical
75+ -> Result T.Canonical
8276canonicalizeAlias region env (name, tvars, dealiasedTipe) types =
8377 let
84− typesLen = length types
85− tvarsLen = length tvars
78+ typesLen =
79+ length types
80+
81+ tvarsLen =
82+ length tvars
8683
8784 toAlias canonicalTypes =
8885 T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)
8986 in
9087 if typesLen /= tvarsLen then
91− Result.err (A.A region (Error.alias name tvarsLen typesLen))
88+ Result.throw region (Error.alias name tvarsLen typesLen)
9289
9390 else
9491 toAlias <$> Trav.traverse (tipe env) types
src/Canonicalize/Variable.hs+47−23
@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Variable (variable, tvar, pvar) where
2+module Canonicalize.Variable (Result, variable, tvar, pvar) where
33
44import qualified Data.Either as Either
55import qualified Data.Map as Map
@@ -9,20 +9,43 @@ import qualified AST.Helpers as Help
99import qualified AST.Module.Name as ModuleName
1010import qualified AST.Type as Type
1111import qualified AST.Variable as Var
12−import qualified Reporting.Annotation as A
12+import qualified Canonicalize.Environment as Env
1313import qualified Reporting.Error.Canonicalize as Error
1414import qualified Reporting.Error.Helpers as Error
1515import qualified Reporting.Region as R
16−import qualified Canonicalize.Environment as Env
17−import qualified Canonicalize.Result as Result
16+import qualified Reporting.Result as Result
17+import qualified Reporting.Warning as Warning
1818import Elm.Utils ((|>))
1919
2020
2121
22+-- RESULT HELPERS
23+
24+
25+type Result a =
26+ Result.Result (Set.Set ModuleName.Raw) Warning.Warning Error.Error a
27+
28+
29+logVarWith :: (a -> Var.Canonical) -> a -> Result a
30+logVarWith toVar value =
31+ case toVar value of
32+ Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->
33+ Result.accumulate (Set.singleton moduleName) value
34+
35+ Var.Canonical _ _ ->
36+ Result.ok value
37+
38+
39+logVar :: Var.Canonical -> Result Var.Canonical
40+logVar var =
41+ logVarWith id var
42+
43+
44+
2245-- FINDERS
2346
2447
25−variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical
48+variable :: R.Region -> Env.Environment -> String -> Result Var.Canonical
2649variable region env var =
2750 case toVarName var of
2851 Right (name, varName) | ModuleName.isNative name ->
@@ -33,12 +56,12 @@ variable region env var =
3356 moduleName =
3457 ModuleName.Canonical localPkg name
3558 in
36− Result.var (Var.Canonical (Var.Module moduleName) varName)
59+ logVar (Var.Canonical (Var.Module moduleName) varName)
3760
3861 _ ->
3962 case Set.toList `fmap` Map.lookup var (Env._values env) of
4063 Just [v] ->
41− Result.var v
64+ logVar v
4265
4366 Just vs ->
4467 preferLocals region env "variable" vs var
@@ -51,7 +74,7 @@ tvar
5174 :: R.Region
5275 -> Env.Environment
5376 -> String
54− -> Result.ResultErr
77+ -> Result
5578 (Either
5679 Var.Canonical
5780 (Var.Canonical, [String], Type.Canonical)
@@ -59,7 +82,7 @@ tvar
5982tvar region env var =
6083 case unions ++ aliases of
6184 [] -> notFound region "type" (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var
62− [v] -> Result.var' extract v
85+ [v] -> logVarWith extract v
6386 vs -> preferLocals' region env extract "type" vs var
6487 where
6588 unions =
@@ -79,23 +102,24 @@ pvar
79102 -> Env.Environment
80103 -> String
81104 -> Int
82− -> Result.ResultErr Var.Canonical
105+ -> Result Var.Canonical
83106pvar region env var actualArgs =
84107 case Set.toList `fmap` Map.lookup var (Env._patterns env) of
85108 Just [value] ->
86109 foundArgCheck value
87110
88111 Just values ->
89− preferLocals' region env fst "pattern" values var
90− `Result.andThen` foundArgCheck
112+ foundArgCheck =<< preferLocals' region env fst "pattern" values var
91113
92114 Nothing ->
93115 notFound region "pattern" (Map.keys (Env._patterns env)) var
94116 where
95117 foundArgCheck (name, expectedArgs) =
96− if actualArgs == expectedArgs
97− then Result.var name
98− else Result.err (A.A region (Error.argMismatch name expectedArgs actualArgs))
118+ if actualArgs == expectedArgs then
119+ logVar name
120+
121+ else
122+ Result.throw region (Error.argMismatch name expectedArgs actualArgs)
99123
100124
101125
@@ -108,7 +132,7 @@ preferLocals
108132 -> String
109133 -> [Var.Canonical]
110134 -> String
111− -> Result.ResultErr Var.Canonical
135+ -> Result Var.Canonical
112136preferLocals region env =
113137 preferLocals' region env id
114138
@@ -120,28 +144,28 @@ preferLocals'
120144 -> String
121145 -> [a]
122146 -> String
123− -> Result.ResultErr a
147+ -> Result a
124148preferLocals' region env extract kind possibilities var =
125149 case filter (isLocal (Env._home env) . extract) possibilities of
126150 [] ->
127151 ambiguous possibilities
128152
129153 [v] ->
130− Result.var' extract v
154+ logVarWith extract v
131155
132156 --Local vars shadow top-level vars
133157 [v1, v2]
134158 | isTopLevel (extract v1) ->
135− Result.var' extract v2
159+ logVarWith extract v2
136160
137161 | isTopLevel (extract v2) ->
138− Result.var' extract v1
162+ logVarWith extract v1
139163
140164 locals ->
141165 ambiguous locals
142166 where
143167 ambiguous possibleVars =
144− Result.err (A.A region (Error.variable kind var Error.Ambiguous vars))
168+ Result.throw region (Error.variable kind var Error.Ambiguous vars)
145169 where
146170 vars = map (Var.toString . extract) possibleVars
147171
@@ -208,7 +232,7 @@ isOp name =
208232-- NOT FOUND
209233
210234
211−notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a
235+notFound :: R.Region -> String -> [String] -> String -> Result a
212236notFound region kind possibilities var =
213237 let name =
214238 toVarName var
@@ -224,7 +248,7 @@ notFound region kind possibilities var =
224248 Right (modul, varName) ->
225249 qualifiedProblem modul varName (Either.rights possibleNames)
226250 in
227− Result.err (A.A region (Error.variable kind var problem suggestions))
251+ Result.throw region (Error.variable kind var problem suggestions)
228252
229253
230254exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])
src/Compile.hs+10−5
@@ -14,23 +14,28 @@ import qualified Optimize
1414import qualified Parse.Helpers as Parse
1515import qualified Parse.Parse as Parse
1616import qualified Reporting.Error as Error
17+import qualified Reporting.Render.Type as RenderType
1718import qualified Reporting.Result as Result
1819import qualified Reporting.Warning as Warning
1920import qualified Type.Inference as TI
2021
2122
23+
24+type Result =
25+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error
26+
27+
2228compile
2329 :: Package.Name
2430 -> [ModuleName.Canonical]
2531 -> Module.Interfaces
2632 -> String
27− -> Result.Result Warning.Warning Error.Error Module.Optimized
28−
33+ -> Result Module.Optimized
2934compile packageName canonicalImports interfaces source =
3035 do
3136 -- Parse the source code
3237 validModule <-
33− Result.mapError Error.Syntax $
38+ Result.format Error.Syntax $
3439 Parse.program packageName (getOpTable interfaces) source
3540
3641 -- Canonicalize all variables, pinning down where they came from.
@@ -43,11 +48,11 @@ compile packageName canonicalImports interfaces source =
4348 TI.infer interfaces canonicalModule
4449
4550 -- One last round of checks
46− Result.mapError Error.Type $
51+ Result.format Error.Type $
4752 Nitpick.topLevelTypes types (Module.validDecls (Module.info validModule))
4853
4954 tagDict <-
50− Result.mapError Error.Pattern $
55+ Result.format Error.Pattern $
5156 Nitpick.patternMatches interfaces canonicalModule
5257
5358 -- Add the real list of types
src/Docs/Check.hs+4−2
@@ -1,4 +1,4 @@
1−module Docs.Check (check) where
1+module Docs.Check (Result, check) where
22
33import qualified Data.List as List
44import qualified Data.Map as Map
@@ -22,7 +22,9 @@ import qualified Reporting.Region as R
2222import qualified Reporting.Result as R
2323
2424
25−type Result w a = R.Result w Error.Error a
25+
26+type Result w a =
27+ R.Result () w Error.Error a
2628
2729
2830-- CHECK DOCUMENTATION
src/Elm/Compiler.hs+14−24
@@ -25,6 +25,7 @@ import qualified Generate.JavaScript as JS
2525import qualified Parse.Module as Parse
2626import qualified Parse.Parse as Parse
2727import qualified Reporting.Annotation as A
28+import qualified Reporting.Bag as Bag
2829import qualified Reporting.Error as Error
2930import qualified Reporting.Render.Type as RenderType
3031import qualified Reporting.Report as Report
@@ -48,18 +49,13 @@ version =
4849parseDependencies :: String -> Either [Error] (PublicModule.Raw, [PublicModule.Raw])
4950parseDependencies sourceCode =
5051 let
51− (Result.Result _warnings rawResult) =
52+ (Result.Result _ _ answer) =
5253 Parse.parse sourceCode Parse.header
53− in
54− case rawResult of
55− Result.Err msgs ->
56− Left $ map (Error . A.map Error.Syntax) msgs
5754
58− Result.Ok (Module.Header _ name _ _ _ imports) ->
59− Right
60− ( name
61− , map (fst . A.drop) imports
62− )
55+ getDeps (Module.Header _ name _ _ _ imports) =
56+ ( name, map (fst . A.drop) imports )
57+ in
58+ Result.answerToEither (Error . A.map Error.Syntax) getDeps answer
6359
6460
6561
@@ -78,18 +74,18 @@ compile context source interfaces =
7874 (Context packageName isExposed dependencies) =
7975 context
8076
81− (Result.Result (localizer, warnings) rawResult) =
77+ (Result.Result oneLocalizer warnings answer) =
8278 do modul <- Compile.compile packageName dependencies interfaces source
83− docs <- docsGen isExposed modul
79+ docs <- Result.format Error.Docs (docsGen isExposed modul)
8480
8581 let interface = Module.toInterface packageName modul
8682 let javascript = JS.generate modul
8783
8884 return (Result docs interface javascript)
8985 in
90− ( maybe dummyLocalizer Localizer localizer
91− , map Warning warnings
92− , Result.destruct (Left . map Error) Right rawResult
86+ ( Result.oneToValue dummyLocalizer Localizer oneLocalizer
87+ , Bag.toList Warning warnings
88+ , Result.answerToEither Error id answer
9389 )
9490
9591
@@ -107,23 +103,17 @@ data Result = Result
107103 }
108104
109105
110−docsGen
111− :: Bool
112− -> Module.Optimized
113− -> Result.Result w Error.Error (Maybe Docs.Documentation)
106+docsGen :: Bool -> Module.Optimized -> Docs.Result w (Maybe Docs.Documentation)
114107docsGen isExposed (Module.Module name _ info) =
115108 if not isExposed then
116109 Result.ok Nothing
117110
118111 else
119112 let
120− getChecked =
121− Docs.check (Module.exports info) (Module.docs info)
122−
123113 toDocs checked =
124− Docs.fromCheckedDocs (ModuleName._module name) checked
114+ Just (Docs.fromCheckedDocs (ModuleName._module name) checked)
125115 in
126− (Just . toDocs) `fmap` Result.mapError Error.Docs getChecked
116+ toDocs <$> Docs.check (Module.exports info) (Module.docs info)
127117
128118
129119
src/Nitpick/PatternMatches.hs+9−16
@@ -23,10 +23,11 @@ import qualified Reporting.Result as Result
2323
2424
2525
26−patternMatches
27− :: Module.Interfaces
28− -> Module.Canonical
29− -> Result.Result w Error.Error DT.VariantDict
26+type Result warning a =
27+ Result.Result () warning Error.Error a
28+
29+
30+patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
3031patternMatches interfaces (Module.Module name _ info) =
3132 let
3233 tagDict =
@@ -118,10 +119,7 @@ lookupOtherTags (Var.Canonical home name) tagDict =
118119-- CHECK EXPRESSIONS
119120
120121
121−checkExpression
122− :: TagDict
123− -> Canonical.Expr
124− -> Result.Result w Error.Error ()
122+checkExpression :: TagDict -> Canonical.Expr -> Result wrn ()
125123checkExpression tagDict (A.A region expression) =
126124 let
127125 go =
@@ -206,12 +204,7 @@ checkExpression tagDict (A.A region expression) =
206204-- CHECK PATTERNS
207205
208206
209−checkPatterns
210− :: TagDict
211− -> Region.Region
212− -> Error.Origin
213− -> [Pattern.Canonical]
214− -> Result.Result w Error.Error ()
207+checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
215208checkPatterns tagDict region origin patterns =
216209 checkPatternsHelp tagDict region origin [Anything] patterns
217210
@@ -222,7 +215,7 @@ checkPatternsHelp
222215 -> Error.Origin
223216 -> [Pattern]
224217 -> [Pattern.Canonical]
225− -> Result.Result w Error.Error ()
218+ -> Result wrn ()
226219checkPatternsHelp tagDict region origin unhandled patterns =
227220 case (unhandled, patterns) of
228221 ([], []) ->
@@ -241,7 +234,7 @@ filterPatterns
241234 -> Region.Region
242235 -> Pattern.Canonical
243236 -> [Pattern]
244− -> Result.Result w Error.Error [Pattern]
237+ -> Result wrn [Pattern]
245238filterPatterns tagDict region pattern unhandled =
246239 let
247240 nitPattern =
src/Nitpick/TopLevelTypes.hs+8−7
@@ -21,13 +21,14 @@ import qualified Reporting.Warning as Warning
2121
2222
2323
24+type Result =
25+ Result.Result () Warning.Warning Error.Error
26+
27+
2428-- CHECK TOP LEVEL TYPES
2529
2630
27−topLevelTypes
28− :: Map.Map String Type.Canonical
29− -> Decl.Valid
30− -> Result.Result Warning.Warning Error.Error ()
31+topLevelTypes :: Map.Map String Type.Canonical -> Decl.Valid -> Result ()
3132topLevelTypes typeEnv (Decl.Decls defs _ _ _) =
3233 do maybeMainRegion <- foldM (warnMissingAnnotation typeEnv) Nothing defs
3334 maybe (return ()) (checkMainType typeEnv) maybeMainRegion
@@ -41,12 +42,12 @@ warnMissingAnnotation
4142 :: Map.Map String Type.Canonical
4243 -> Maybe R.Region
4344 -> A.Commented Valid.Def
44− -> Result.Result Warning.Warning Error.Error (Maybe R.Region)
45+ -> Result (Maybe R.Region)
4546warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) def) =
4647 case def of
4748 Valid.Def (A.A _ (P.Var name)) _ maybeType ->
4849 do when (Maybe.isNothing maybeType) $
49− Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name))
50+ Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name)) ()
5051
5152 return (if name == "main" then Just region else maybeMainRegion)
5253
@@ -58,7 +59,7 @@ warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) def) =
5859-- CHECK MAIN TYPE
5960
6061
61−checkMainType :: Map.Map String Type.Canonical -> R.Region -> Result.Result w Error.Error ()
62+checkMainType :: Map.Map String Type.Canonical -> R.Region -> Result ()
6263checkMainType typeEnv region =
6364 let
6465 tipe =
src/Parse/Parse.hs+4−12
@@ -20,11 +20,7 @@ import qualified Validate
2020
2121
2222
23−program
24− :: Package.Name
25− -> OpTable
26− -> String
27− -> Result.Result wrn Error.Error Module.Valid
23+program :: Package.Name -> OpTable -> String -> Validate.Result wrn Module.Valid
2824program pkgName table src =
2925 do modul <-
3026 parseWithTable table src (programParser pkgName)
@@ -72,7 +68,7 @@ freshDef =
7268-- RUN PARSERS
7369
7470
75−parse :: String -> IParser a -> Result.Result wrn Error.Error a
71+parse :: String -> IParser a -> Validate.Result wrn a
7672parse source parser =
7773 case iParse parser source of
7874 Right result ->
@@ -85,11 +81,7 @@ parse source parser =
8581 Result.throw (R.Region pos pos) (Error.Parse msgs)
8682
8783
88−parseWithTable
89− :: OpTable
90− -> String
91− -> IParser a
92− -> Result.Result wrn Error.Error a
84+parseWithTable :: OpTable -> String -> IParser a -> Validate.Result wrn a
9385parseWithTable table source parser =
9486 do infixInfoList <- parse source parseFixities
9587
@@ -107,7 +99,7 @@ parseWithTable table source parser =
10799makeInfixTable
108100 :: Map.Map String (Int, Decl.Assoc)
109101 -> [(String, InfixInfo)]
110− -> Result.Result wrn Error.Error (Map.Map String (Int, Decl.Assoc))
102+ -> Validate.Result wrn (Map.Map String (Int, Decl.Assoc))
111103makeInfixTable table newInfo =
112104 let add (op, info) dict =
113105 Map.insertWith (++) op [info] dict
src/Reporting/Bag.hsnew file+101
@@ -0,0 +1,101 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Reporting.Bag
3+ ( Bag
4+ , empty, singleton, cons, append, map
5+ , toList, fromList
6+ )
7+ where
8+
9+
10+import Prelude hiding (map)
11+
12+
13+
14+-- BAGS
15+
16+
17+data Bag a
18+ = Empty
19+ | One a
20+ | Two (Bag a) (Bag a)
21+ | Many [a]
22+
23+
24+empty :: Bag a
25+empty =
26+ Empty
27+
28+
29+singleton :: a -> Bag a
30+singleton =
31+ One
32+
33+
34+cons :: a -> Bag a -> Bag a
35+cons x bag =
36+ case bag of
37+ Empty ->
38+ One x
39+
40+ _ ->
41+ Two (One x) bag
42+
43+
44+append :: Bag a -> Bag a -> Bag a
45+append left right =
46+ case (left, right) of
47+ (other, Empty) ->
48+ other
49+
50+ (Empty, other) ->
51+ other
52+
53+ (_, _) ->
54+ Two left right
55+
56+
57+map :: (a -> b) -> Bag a -> Bag b
58+map func bag =
59+ case bag of
60+ Empty ->
61+ Empty
62+
63+ One x ->
64+ One (func x)
65+
66+ Two left right ->
67+ Two (map func left) (map func right)
68+
69+ Many xs ->
70+ Many (fmap func xs)
71+
72+
73+
74+-- LIST CONVERSIONS
75+
76+
77+fromList :: [a] -> Bag a
78+fromList =
79+ Many
80+
81+
82+toList :: (a -> b) -> Bag a -> [b]
83+toList func bag =
84+ toListHelp func bag []
85+
86+
87+toListHelp :: (a -> b) -> Bag a -> [b] -> [b]
88+toListHelp func bag list =
89+ case bag of
90+ Empty ->
91+ list
92+
93+ One x ->
94+ func x : list
95+
96+ Two left right ->
97+ toListHelp func left (toListHelp func right list)
98+
99+ Many xs ->
100+ foldr (\x newList -> func x : newList) list xs
101+
src/Reporting/Result.hs+97−57
@@ -1,45 +1,69 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Reporting.Result where
23
3−import Control.Applicative ((<|>))
4−import qualified Control.Monad as M
54import Control.Monad.Except (Except, runExcept)
65
76import qualified Reporting.Annotation as A
7+import qualified Reporting.Bag as Bag
88import qualified Reporting.Region as R
9−import qualified Reporting.Render.Type as RenderType
109
1110
12−-- TASK
1311
14−data Result warning error result =
15− Result
16− (Maybe RenderType.Localizer, [A.Located warning])
17− (RawResult [A.Located error] result)
12+-- RESULTS
1813
1914
20−data RawResult e a
21− = Ok a
22− | Err e
15+data Result info warning error result =
16+ Result
17+ { _info :: info
18+ , _warnings :: LBag warning
19+ , _answer :: Answer (LBag error) result
20+ }
2321
2422
25−-- HELPERS
23+data Answer e a = Ok a | Err e
2624
27−ok :: a -> Result w e a
25+
26+type LBag a =
27+ Bag.Bag (A.Located a)
28+
29+
30+data One a = None | One a
31+
32+
33+
34+-- RESULT HELPERS
35+
36+
37+ok :: (Monoid i) => a -> Result i w e a
2838ok value =
29− Result (Nothing, []) (Ok value)
39+ Result mempty Bag.empty (Ok value)
3040
3141
32−throw :: R.Region -> e -> Result w e a
42+throw :: (Monoid i) => R.Region -> e -> Result i w e a
3343throw region err =
34− Result (Nothing, []) (Err [A.A region err])
44+ Result mempty Bag.empty (Err (Bag.singleton (A.A region err)))
3545
3646
37−throwMany :: [A.Located e] -> Result w e a
47+throwMany :: (Monoid i) => [A.Located e] -> Result i w e a
3848throwMany errors =
39− Result (Nothing, []) (Err errors)
49+ Result mempty Bag.empty (Err (Bag.fromList errors))
50+
51+
52+accumulate :: (Monoid i) => i -> a -> Result i w e a
53+accumulate info value =
54+ Result info Bag.empty (Ok value)
55+
4056
57+warn :: (Monoid i) => R.Region -> w -> a -> Result i w e a
58+warn region warning a =
59+ Result mempty (Bag.singleton (A.A region warning)) (Ok a)
4160
42−from :: (e -> e') -> Except [A.Located e] a -> Result w e' a
61+
62+
63+-- EXTRACTION HELPERS
64+
65+
66+from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a
4367from f except =
4468 case runExcept except of
4569 Right answer ->
@@ -49,66 +73,68 @@ from f except =
4973 throwMany (map (A.map f) errors)
5074
5175
52−mapError :: (e -> e') -> Result w e a -> Result w e' a
53−mapError f (Result warnings rawResult) =
54− Result warnings $
76+mapError :: (e -> e') -> Result i w e a -> Result i w e' a
77+mapError f (Result info warnings rawResult) =
78+ Result info warnings $
5579 case rawResult of
5680 Ok v ->
5781 Ok v
5882
5983 Err msgs ->
60− Err (map (A.map f) msgs)
84+ Err (Bag.map (A.map f) msgs)
6185
6286
63−warn :: R.Region -> w -> Result w e ()
64−warn region warning =
65− Result (Nothing, [A.A region warning]) (Ok ())
87+format :: (Monoid i) => (e -> e') -> Result () w e a -> Result i w e' a
88+format func (Result _ warnings answer) =
89+ mapError func (Result mempty warnings answer)
6690
6791
68−addWarnings :: [A.Located w] -> Result w e a -> Result w e a
69−addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =
70− Result (dealiaser, newWarnings ++ warnings) rawResult
92+answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'
93+answerToEither onErr onOk answer =
94+ case answer of
95+ Ok value ->
96+ Right (onOk value)
7197
98+ Err errors ->
99+ Left (Bag.toList onErr errors)
72100
73−addDealiaser :: RenderType.Localizer -> Result w e a -> Result w e a
74−addDealiaser dealiaser (Result (_, warnings) rawResult) =
75− Result (Just dealiaser, warnings) rawResult
76101
102+oneToValue :: b -> (a -> b) -> One a -> b
103+oneToValue fallback onOne one =
104+ case one of
105+ None ->
106+ fallback
77107
78−destruct :: (e -> b) -> (a -> b) -> RawResult e a -> b
79−destruct errFunc okFunc rawResult =
80− case rawResult of
81− Ok answer ->
82− okFunc answer
108+ One value ->
109+ onOne value
83110
84− Err errors ->
85− errFunc errors
86111
87112
88113-- EXTRA FANCY HELPERS
89114
90−instance M.Functor (Result w e) where
91− fmap func (Result warnings rawResult) =
115+
116+instance Functor (Result i w e) where
117+ fmap func (Result info warnings rawResult) =
92118 case rawResult of
93119 Ok a ->
94− Result warnings (Ok (func a))
120+ Result info warnings (Ok (func a))
95121
96122 Err msgs ->
97− Result warnings (Err msgs)
123+ Result info warnings (Err msgs)
98124
99125
100−instance Applicative (Result w e) where
126+instance (Monoid i) => Applicative (Result i w e) where
101127 pure value =
102128 ok value
103129
104− (<*>) (Result context resultFunc) (Result context' resultVal) =
105− Result (merge context context') $
130+ (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =
131+ Result (mappend info info') (Bag.append warnings warnings') $
106132 case (resultFunc, resultVal) of
107133 (Ok func, Ok val) ->
108134 Ok (func val)
109135
110136 (Err msgs, Err msgs') ->
111− Err (msgs ++ msgs')
137+ Err (Bag.append msgs msgs')
112138
113139 (Err msgs, _) ->
114140 Err msgs
@@ -117,23 +143,37 @@ instance Applicative (Result w e) where
117143 Err msgs
118144
119145
120−instance M.Monad (Result w e) where
146+instance (Monoid i) => Monad (Result i w e) where
121147 return value =
122148 ok value
123149
124− (>>=) (Result context rawResult) callback =
150+ (>>=) (Result info warnings rawResult) callback =
125151 case rawResult of
126152 Err msg ->
127− Result context (Err msg)
153+ Result info warnings (Err msg)
128154
129155 Ok value ->
130− let (Result context' rawResult') = callback value
156+ let
157+ (Result info' warnings' rawResult') =
158+ callback value
131159 in
132− Result (merge context context') rawResult'
160+ Result
161+ (mappend info info')
162+ (Bag.append warnings warnings')
163+ rawResult'
164+
165+
166+instance Monoid (One a) where
167+ mempty =
168+ None
169+
170+ mappend left right =
171+ case (left, right) of
172+ (other, None) ->
173+ other
133174
175+ (None, other) ->
176+ other
134177
135−merge :: (Maybe a, [b]) -> (Maybe a, [b]) -> (Maybe a, [b])
136−merge (dealiaser, warnings) (dealiaser', warnings') =
137− ( dealiaser <|> dealiaser'
138− , warnings ++ warnings'
139− )
178+ (One _, One _) ->
179+ error "There should only be one!"
src/Validate.hs+32−43
@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Validate (module') where
2+module Validate (Result, module') where
33
44import Prelude hiding (init)
55import Control.Monad (foldM, when)
@@ -28,10 +28,15 @@ import qualified Reporting.Result as Result
2828
2929
3030
31+type Result warning a =
32+ Result.Result () warning Error.Error a
33+
34+
35+
3136-- MODULES
3237
3338
34−module' :: Module.Source -> Result.Result wrn Error.Error Module.Valid
39+module' :: Module.Source -> Result wrn Module.Valid
3540module' (Module.Module name path info) =
3641 let
3742 (ModuleName.Canonical pkgName _) =
@@ -74,7 +79,7 @@ validateEffects
7479 -> Module.SourceSettings
7580 -> [A.Commented Effects.ForeignRaw]
7681 -> [A.Commented Valid.Def]
77− -> Result.Result wrn Error.Error Effects.Raw
82+ -> Result wrn Effects.Raw
7883validateEffects tag settings@(A.A _ pairs) foreigns validDefs =
7984 case tag of
8085 Module.Normal ->
@@ -100,10 +105,7 @@ validateEffects tag settings@(A.A _ pairs) foreigns validDefs =
100105 return (Effects.Manager (Effects.Info tagRegion r0 r1 r2 managerType))
101106
102107
103−noSettings
104− :: Error.Error
105− -> Module.SourceSettings
106− -> Result.Result wrn Error.Error ()
108+noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
107109noSettings errorMsg (A.A region settings) =
108110 case settings of
109111 [] ->
@@ -113,7 +115,7 @@ noSettings errorMsg (A.A region settings) =
113115 Result.throw region errorMsg
114116
115117
116−noForeigns :: [A.Commented Effects.ForeignRaw] -> Result.Result wrn Error.Error ()
118+noForeigns :: [A.Commented Effects.ForeignRaw] -> Result wrn ()
117119noForeigns foreigns =
118120 case foreigns of
119121 [] ->
@@ -130,7 +132,7 @@ noForeigns foreigns =
130132toManagerType
131133 :: R.Region
132134 -> Map.Map String [(R.Region, A.Located String)]
133− -> Result.Result wrn Error.Error Effects.ManagerType
135+ -> Result wrn Effects.ManagerType
134136toManagerType tagRegion settingsDict =
135137 let
136138 toErrors name entries =
@@ -167,7 +169,7 @@ toManagerType tagRegion settingsDict =
167169extractOne
168170 :: String
169171 -> Map.Map String [(R.Region, A.Located String)]
170− -> Result.Result w Error.Error (Maybe (A.Located String))
172+ -> Result wrn (Maybe (A.Located String))
171173extractOne name settingsDict =
172174 case Map.lookup name settingsDict of
173175 Nothing ->
@@ -191,7 +193,7 @@ checkManager
191193 :: R.Region
192194 -> Effects.ManagerType
193195 -> [A.Commented Valid.Def]
194− -> Result.Result w Error.Error (R.Region, R.Region, R.Region)
196+ -> Result wrn (R.Region, R.Region, R.Region)
195197checkManager tagRegion managerType validDefs =
196198 let
197199 regionDict =
@@ -218,7 +220,7 @@ requireMaps
218220 :: R.Region
219221 -> Map.Map String R.Region
220222 -> Effects.ManagerType
221− -> Result.Result w Error.Error ()
223+ -> Result wrn ()
222224requireMaps tagRegion regionDict managerType =
223225 let
224226 check name =
@@ -236,11 +238,7 @@ requireMaps tagRegion regionDict managerType =
236238 check "cmdMap" <* check "subMap"
237239
238240
239−requireRegion
240− :: R.Region
241− -> Map.Map String R.Region
242− -> String
243− -> Result.Result w Error.Error R.Region
241+requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region
244242requireRegion tagRegion regionDict name =
245243 case Map.lookup name regionDict of
246244 Just region ->
@@ -254,7 +252,7 @@ requireRegion tagRegion regionDict name =
254252-- COLLAPSE COMMENTS
255253
256254
257−collapseComments :: [D.CommentOr (A.Located a)] -> Result.Result wrn Error.Error [A.Commented a]
255+collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
258256collapseComments listWithComments =
259257 case listWithComments of
260258 [] ->
@@ -284,7 +282,7 @@ collapseComments listWithComments =
284282-- VALIDATE STRUCTURED SOURCE
285283
286284
287−validateDecls :: [D.Source] -> Result.Result wrn Error.Error ValidStuff
285+validateDecls :: [D.Source] -> Result wrn ValidStuff
288286validateDecls sourceDecls =
289287 do rawDecls <- collapseComments sourceDecls
290288
@@ -309,7 +307,7 @@ data ValidStuff =
309307 }
310308
311309
312−validateRawDecls :: [A.Commented D.Raw] -> Result.Result wrn Error.Error ValidStuff
310+validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
313311validateRawDecls commentedDecls =
314312 vrdHelp commentedDecls [] (D.Decls [] [] [] [])
315313
@@ -318,7 +316,7 @@ vrdHelp
318316 :: [A.Commented D.Raw]
319317 -> [A.Commented Effects.ForeignRaw]
320318 -> D.Valid
321− -> Result.Result wrn Error.Error ValidStuff
319+ -> Result wrn ValidStuff
322320vrdHelp commentedDecls foreigns structure =
323321 case commentedDecls of
324322 [] ->
@@ -347,7 +345,7 @@ vrdDefHelp
347345 -> A.Commented Source.Def'
348346 -> [A.Commented Effects.ForeignRaw]
349347 -> D.Valid
350− -> Result.Result wrn Error.Error ValidStuff
348+ -> Result wrn ValidStuff
351349vrdDefHelp remainingDecls (A.A ann def) foreigns structure =
352350 let
353351 addDef validDef (ValidStuff finalForeigns struct) =
@@ -376,7 +374,7 @@ vrdDefHelp remainingDecls (A.A ann def) foreigns structure =
376374-- VALIDATE DEFINITIONS
377375
378376
379−definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
377+definitions :: [Source.Def] -> Result wrn [Valid.Def]
380378definitions sourceDefs =
381379 do validDefs <- definitionsHelp sourceDefs
382380
@@ -388,7 +386,7 @@ definitions sourceDefs =
388386 return validDefs
389387
390388
391−definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
389+definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]
392390definitionsHelp sourceDefs =
393391 case sourceDefs of
394392 [] ->
@@ -415,14 +413,14 @@ validateDef
415413 :: Pattern.Raw
416414 -> Source.Expr
417415 -> Maybe Type.Raw
418− -> Result.Result wrn Error.Error Valid.Def
416+ -> Result wrn Valid.Def
419417validateDef pat expr maybeType =
420418 do validExpr <- expression expr
421419 validateDefPattern pat validExpr
422420 return $ Valid.Def pat validExpr maybeType
423421
424422
425−validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
423+validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()
426424validateDefPattern pattern body =
427425 case fst (Expr.collectLambdas body) of
428426 [] ->
@@ -445,7 +443,7 @@ validateDefPattern pattern body =
445443-- VALIDATE EXPRESSIONS
446444
447445
448−expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
446+expression :: Source.Expr -> Result wrn Valid.Expr
449447expression (A.A ann sourceExpression) =
450448 A.A ann <$>
451449 case sourceExpression of
@@ -538,14 +536,12 @@ expression (A.A ann sourceExpression) =
538536 return (GLShader uid src gltipe)
539537
540538
541−second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
539+second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
542540second (value, expr) =
543541 (,) value <$> expression expr
544542
545543
546−both
547− :: (Source.Expr, Source.Expr)
548− -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
544+both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
549545both (expr1, expr2) =
550546 (,) <$> expression expr1 <*> expression expr2
551547
@@ -554,7 +550,7 @@ both (expr1, expr2) =
554550-- VALIDATE PATTERNS
555551
556552
557−validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
553+validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
558554validatePattern pattern =
559555 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
560556 return pattern
@@ -564,7 +560,7 @@ validatePattern pattern =
564560-- DETECT DUPLICATES
565561
566562
567−checkDuplicates :: ValidStuff -> Result.Result wrn Error.Error ()
563+checkDuplicates :: ValidStuff -> Result wrn ()
568564checkDuplicates (ValidStuff foreigns (D.Decls defs unions aliases _)) =
569565 let
570566 -- SIMPLE NAMES
@@ -604,10 +600,7 @@ checkDuplicates (ValidStuff foreigns (D.Decls defs unions aliases _)) =
604600 ]
605601
606602
607−detectDuplicates
608− :: (String -> Error.Error)
609− -> [A.Located String]
610− -> Result.Result wrn Error.Error ()
603+detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
611604detectDuplicates tag names =
612605 let
613606 add (A.A region name) dict =
@@ -631,9 +624,7 @@ detectDuplicates tag names =
631624-- UNBOUND TYPE VARIABLES
632625
633626
634−checkTypeVarsInUnion
635− :: A.Commented (D.Union Type.Raw)
636− -> Result.Result wrn Error.Error ()
627+checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
637628checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
638629 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
639630 (_, []) ->
@@ -644,9 +635,7 @@ checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
644635 (Error.UnboundTypeVarsInUnion name boundVars unbound)
645636
646637
647−checkTypeVarsInAlias
648− :: A.Commented (D.Alias Type.Raw)
649− -> Result.Result wrn Error.Error ()
638+checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
650639checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
651640 case diff boundVars (freeVars tipe) of
652641 ([], []) ->