git.iko.soy/elk
on master help sign in
Create special "error type" that has extra information
344579bEvan Czaplicki
src/Reporting/Error/Type.hs+390−209
compare with master
unifiedsplit
@@ -2,7 +2,23 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Type
3module Reporting.Error.Type
4 ( Error(..)
4 ( Error(..)
5+ -- expectations
5 , Origin(..)
6 , Origin(..)
7+ , Expected(..)
8+ , Context(..)
9+ , SubContext(..)
10+ , MaybeName(..)
11+ , Category(..)
12+ , PExpected(..)
13+ , PContext(..)
14+ , PCategory(..)
15+ , typeReplace
16+ , ptypeReplace
17+ -- error types
18+ , Type(..)
19+ , Extension(..)
20+ , Localizer
21+ -- make reports
6 , toReport
22 , toReport
7 )
23 )
8 where
24 where
@@ -11,17 +27,14 @@ module Reporting.Error.Type
11import Prelude hiding (round)
27import Prelude hiding (round)
12import Data.Monoid ((<>))
28import Data.Monoid ((<>))
13
29
14−import qualified AST.Canonical as Can
15import qualified AST.Module.Name as ModuleName
30import qualified AST.Module.Name as ModuleName
16−import qualified AST.Utils.Type as Type
17import qualified Data.Index as Index
31import qualified Data.Index as Index
32+import qualified Data.Map as Map
18import qualified Elm.Name as N
33import qualified Elm.Name as N
19import qualified Reporting.Helpers as H
34import qualified Reporting.Helpers as H
20import qualified Reporting.Region as R
35import qualified Reporting.Region as R
21import qualified Reporting.Render.Code as Code
36import qualified Reporting.Render.Code as Code
22−import qualified Reporting.Render.Type as Type
23import qualified Reporting.Report as Report
37import qualified Reporting.Report as Report
24−import qualified Type.Constraint as C
25
38
26
39
27
40
@@ -29,22 +42,159 @@ import qualified Type.Constraint as C
29
42
30
43
31data Error
44data Error
32− = Mismatch Origin (C.Expected Can.Type)
45+ = Mismatch Origin (Expected Type)
33− | BadPattern R.Region C.PCategory Can.Type (C.PExpected Can.Type)
46+ | BadPattern R.Region PCategory Type (PExpected Type)
34− | InfiniteType Can.Type
47+ | InfiniteType Type
48+
49+
50+
51+-- EXPRESSION EXPECTATIONS
35
52
36
53
37data Origin
54data Origin
38− = BadExpr R.Region C.Category Can.Type
55+ = BadExpr R.Region Category Type
39− | BadLocal R.Region N.Name Can.Type
56+ | BadLocal R.Region N.Name Type
40− | BadForeign R.Region N.Name Can.Type
57+ | BadForeign R.Region N.Name Type
58+
59+
60+data Expected tipe
61+ = NoExpectation tipe
62+ | FromContext R.Region Context tipe
63+ | FromAnnotation N.Name Int SubContext tipe
64+
65+
66+data Context
67+ = ListEntry Index.ZeroBased
68+ | Negate
69+ | OpLeft N.Name
70+ | OpRight N.Name
71+ | IfCondition
72+ | IfBranch Index.ZeroBased
73+ | CaseBranch Index.ZeroBased
74+ | CallArg MaybeName Index.ZeroBased
75+ | TooManyArgs MaybeName Int
76+ | RecordAccess N.Name
77+ | RecordUpdate
78+ | Destructure
79+
80+
81+data SubContext
82+ = TypedIfBranch Index.ZeroBased
83+ | TypedCaseBranch Index.ZeroBased
84+ | TypedBody
85+
86+
87+data MaybeName
88+ = FuncName N.Name
89+ | CtorName N.Name
90+ | OpName N.Name
91+ | NoName
92+
93+
94+data Category
95+ = List
96+ | Number
97+ | Float
98+ | String
99+ | Char
100+ | If
101+ | Case
102+ | CallResult MaybeName
103+ | LambdaExpr
104+ | Accessor N.Name
105+ | Access N.Name
106+ | RecordExpr
107+ | TupleExpr
108+ | UnitExpr
109+ | Shader
110+ | Effects
111+
112+
113+
114+-- PATTERN EXPECTATIONS
115+
116+
117+data PExpected tipe
118+ = PNoExpectation tipe
119+ | PFromContext R.Region PContext tipe
120+
121+
122+data PContext
123+ = PTypedArg N.Name Index.ZeroBased
124+ | PCaseMatch Index.ZeroBased
125+ | PCtorArg N.Name Index.ZeroBased
126+ | PListEntry Index.ZeroBased
127+ | PTail
128+
129+
130+data PCategory
131+ = PRecord
132+ | PUnit
133+ | PTuple
134+ | PList
135+ | PCtor N.Name
136+ | PInt
137+ | PStr
138+ | PChr
139+
140+
141+
142+-- HELPERS
143+
144+
145+typeReplace :: Expected a -> b -> Expected b
146+typeReplace expectation tipe =
147+ case expectation of
148+ NoExpectation _ ->
149+ NoExpectation tipe
150+
151+ FromContext region context _ ->
152+ FromContext region context tipe
153+
154+ FromAnnotation name arity context _ ->
155+ FromAnnotation name arity context tipe
156+
157+
158+ptypeReplace :: PExpected a -> b -> PExpected b
159+ptypeReplace expectation tipe =
160+ case expectation of
161+ PNoExpectation _ ->
162+ PNoExpectation tipe
163+
164+ PFromContext region context _ ->
165+ PFromContext region context tipe
166+
167+
168+
169+-- ERROR TYPES
170+
171+
172+data Type
173+ = Lambda Type [Type]
174+ | Infinite
175+ | Error
176+ | FlexVar N.Name
177+ | FlexSuper N.Name
178+ | RigidVar N.Name
179+ | RigidSuper N.Name
180+ | Type ModuleName.Canonical N.Name [Type]
181+ | Record (Map.Map N.Name Type) Extension
182+ | Unit
183+ | Tuple Type Type (Maybe Type)
184+ | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
185+
186+
187+data Extension
188+ = Closed
189+ | FlexOpen N.Name
190+ | RigidOpen N.Name
41
191
42
192
43
193
44-- TO REPORT
194-- TO REPORT
45
195
46
196
47−toReport :: Code.Source -> Type.Localizer -> Error -> Report.Report
197+toReport :: Code.Source -> Localizer -> Error -> Report.Report
48toReport source localizer err =
198toReport source localizer err =
49 case err of
199 case err of
50 Mismatch origin expected ->
200 Mismatch origin expected ->
@@ -71,27 +221,7 @@ toReport source localizer err =
71
221
72data Thing
222data Thing
73 = Var N.Name
223 = Var N.Name
74− | Category C.Category
224+ | Category Category
75−
76−
77−typeComparison :: Type.Localizer -> Can.Type -> Can.Type -> ( String, String, [H.Doc] ) -> H.Doc
78−typeComparison localizer actual expected ( iAmSeeing, insteadOf, soHereAreSomeThoughts ) =
79− let
80− (actualDoc, expectedDoc) =
81− Type.diffToDocs localizer actual expected
82− in
83− H.stack $
84− [ H.reflow iAmSeeing
85− , H.indent 4 actualDoc
86− , H.reflow insteadOf
87− , H.indent 4 expectedDoc
88− ]
89− ++ soHereAreSomeThoughts
90−
91−
92−indentType :: Type.Localizer -> Can.Type -> H.Doc
93−indentType localizer tipe =
94− H.indent 4 (H.dullyellow (Type.toDoc localizer tipe))
95
225
96
226
97toDescription :: Thing -> String -> String
227toDescription :: Thing -> String -> String
@@ -102,38 +232,38 @@ toDescription thing thatThingIs =
102
232
103 Category category ->
233 Category category ->
104 case category of
234 case category of
105− C.List -> thatThingIs <> " a list of type:"
235+ List -> thatThingIs <> " a list of type:"
106− C.Number -> thatThingIs <> " a number of type:"
236+ Number -> thatThingIs <> " a number of type:"
107− C.Float -> thatThingIs <> " a float of type:"
237+ Float -> thatThingIs <> " a float of type:"
108− C.String -> thatThingIs <> " a string of type:"
238+ String -> thatThingIs <> " a string of type:"
109− C.Char -> thatThingIs <> " a character of type:"
239+ Char -> thatThingIs <> " a character of type:"
110− C.If -> "This `if` expression produces a value of type:"
240+ If -> "This `if` expression produces a value of type:"
111− C.Case -> "This `case` expression produces a value of type:"
241+ Case -> "This `case` expression produces a value of type:"
112− C.Lambda -> thatThingIs <> " an anonymous function of type:"
242+ LambdaExpr -> thatThingIs <> " an anonymous function of type:"
113− C.Accessor field -> "This ." <> N.toString field <> " field access function has type of type:"
243+ Accessor field -> "This ." <> N.toString field <> " field access function has type:"
114− C.Access field -> "The value at ." <> N.toString field <> " has type of type:"
244+ Access field -> "The value at ." <> N.toString field <> " has type:"
115− C.Record -> thatThingIs <> " a record of type:"
245+ RecordExpr -> thatThingIs <> " a record of type:"
116− C.Tuple -> thatThingIs <> " a tuple of type:"
246+ TupleExpr -> thatThingIs <> " a tuple of type:"
117− C.Unit -> thatThingIs <> " a unit value:"
247+ UnitExpr -> thatThingIs <> " a unit value:"
118− C.Shader -> thatThingIs <> " a GLSL shader of type:"
248+ Shader -> thatThingIs <> " a GLSL shader of type:"
119− C.Effects -> thatThingIs <> " a thing for CORE LIBRARIES ONLY."
249+ Effects -> thatThingIs <> " a thing for CORE LIBRARIES ONLY."
120− C.CallResult maybeName ->
250+ CallResult maybeName ->
121 case maybeName of
251 case maybeName of
122− C.NoName -> thatThingIs <> ":"
252+ NoName -> thatThingIs <> ":"
123− C.FuncName name -> "This `" <> N.toString name <> "` call produces:"
253+ FuncName name -> "This `" <> N.toString name <> "` call produces:"
124− C.CtorName name -> "This `" <> N.toString name <> "` call produces:"
254+ CtorName name -> "This `" <> N.toString name <> "` call produces:"
125− C.OpName _ -> thatThingIs <> ":"
255+ OpName _ -> thatThingIs <> ":"
126
256
127
257
128
258
129-- TO MISMATCH REPORT
259-- TO MISMATCH REPORT
130
260
131
261
132−toMismatchReport :: Code.Source -> Type.Localizer -> R.Region -> Thing -> Can.Type -> C.Expected Can.Type -> Report.Report
262+toMismatchReport :: Code.Source -> Localizer -> R.Region -> Thing -> Type -> Expected Type -> Report.Report
133toMismatchReport source localizer exprRegion thing tipe expected =
263toMismatchReport source localizer exprRegion thing tipe expected =
134 Report.Report "TYPE MISMATCH" exprRegion [] $
264 Report.Report "TYPE MISMATCH" exprRegion [] $
135 case expected of
265 case expected of
136− C.NoExpectation expectedType ->
266+ NoExpectation expectedType ->
137 Report.toCodeSnippet source exprRegion Nothing
267 Report.toCodeSnippet source exprRegion Nothing
138 (
268 (
139 "This expression is being used in an unexpected way:"
269 "This expression is being used in an unexpected way:"
@@ -150,31 +280,31 @@ toMismatchReport source localizer exprRegion thing tipe expected =
150 )
280 )
151 )
281 )
152
282
153− C.FromAnnotation name arity subContext expectedType ->
283+ FromAnnotation name arity subContext expectedType ->
154 Report.toCodeSnippet source exprRegion Nothing
284 Report.toCodeSnippet source exprRegion Nothing
155 (
285 (
156 H.reflow $
286 H.reflow $
157 case subContext of
287 case subContext of
158− C.TypedIfBranch index ->
288+ TypedIfBranch index ->
159 "Something is off with the " <> H.ordinalize (Index.toHuman index) <> " branch of this `if` experssion:"
289 "Something is off with the " <> H.ordinalize (Index.toHuman index) <> " branch of this `if` experssion:"
160
290
161− C.TypedCaseBranch index ->
291+ TypedCaseBranch index ->
162 "Something is off with the " <> H.ordinalize (Index.toHuman index) <> " branch of this `case` expression:"
292 "Something is off with the " <> H.ordinalize (Index.toHuman index) <> " branch of this `case` expression:"
163
293
164− C.TypedBody ->
294+ TypedBody ->
165 "Something is off with the body of the `" <> N.toString name <> "` definition:"
295 "Something is off with the body of the `" <> N.toString name <> "` definition:"
166 ,
296 ,
167 typeComparison localizer tipe expectedType
297 typeComparison localizer tipe expectedType
168 (
298 (
169 toDescription thing $
299 toDescription thing $
170 case subContext of
300 case subContext of
171− C.TypedIfBranch index ->
301+ TypedIfBranch index ->
172 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"
302 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"
173
303
174− C.TypedCaseBranch index ->
304+ TypedCaseBranch index ->
175 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"
305 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"
176
306
177− C.TypedBody ->
307+ TypedBody ->
178 "The body is"
308 "The body is"
179 ,
309 ,
180 "But the type annotation on `" <> N.toString name <> "` says it should be:"
310 "But the type annotation on `" <> N.toString name <> "` says it should be:"
@@ -185,9 +315,9 @@ toMismatchReport source localizer exprRegion thing tipe expected =
185 )
315 )
186 )
316 )
187
317
188− C.FromContext region context expectedType ->
318+ FromContext region context expectedType ->
189 case context of
319 case context of
190− C.ListEntry index ->
320+ ListEntry index ->
191 if Index.toHuman index == 2 then
321 if Index.toHuman index == 2 then
192 error "TODO 1st vs 2nd list entry"
322 error "TODO 1st vs 2nd list entry"
193 else
323 else
@@ -213,7 +343,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =
213 )
343 )
214 )
344 )
215
345
216− C.Negate ->
346+ Negate ->
217 Report.toCodeSnippet source region (Just exprRegion)
347 Report.toCodeSnippet source region (Just exprRegion)
218 (
348 (
219 "I do not know how to negate this type of value:"
349 "I do not know how to negate this type of value:"
@@ -229,15 +359,19 @@ toMismatchReport source localizer exprRegion thing tipe expected =
229 ]
359 ]
230 )
360 )
231
361
232− C.OpLeft op ->
362+ OpLeft op ->
233 Report.toCodeSnippet source region (Just exprRegion) $
363 Report.toCodeSnippet source region (Just exprRegion) $
234 opLeftToDocs localizer thing op tipe expectedType
364 opLeftToDocs localizer thing op tipe expectedType
235
365
236− C.OpRight op ->
366+ OpRight op ->
237− Report.toCodeSnippet source region (Just exprRegion) $
238− opRightToDocs localizer thing op tipe expectedType
367+ case opRightToDocs localizer thing op tipe expectedType of
368+ EmphBoth details ->
369+ Report.toCodeSnippet source region Nothing details
239
370
371+ EmphRight details ->
372+ Report.toCodeSnippet source region (Just exprRegion) details
373+
240− C.IfCondition ->
374+ IfCondition ->
241 Report.toCodeSnippet source region (Just exprRegion)
375 Report.toCodeSnippet source region (Just exprRegion)
242 (
376 (
243 "This `if` condition does not evaluate to a boolean value, True or False."
377 "This `if` condition does not evaluate to a boolean value, True or False."
@@ -252,7 +386,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =
252 ]
386 ]
253 )
387 )
254
388
255− C.IfBranch index ->
389+ IfBranch index ->
256 if Index.toHuman index == 2 then
390 if Index.toHuman index == 2 then
257 error "TODO 1st vs 2nd if branches"
391 error "TODO 1st vs 2nd if branches"
258 -- error "TODO if with no chaining"
392 -- error "TODO if with no chaining"
@@ -279,7 +413,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =
279 )
413 )
280 )
414 )
281
415
282− C.CaseBranch index ->
416+ CaseBranch index ->
283 if Index.toHuman index == 2 then
417 if Index.toHuman index == 2 then
284 error "TODO 1st vs 2nd case branches"
418 error "TODO 1st vs 2nd case branches"
285 else
419 else
@@ -305,20 +439,20 @@ toMismatchReport source localizer exprRegion thing tipe expected =
305 )
439 )
306 )
440 )
307
441
308− C.CallArg maybeFuncName index ->
442+ CallArg maybeFuncName index ->
309 let
443 let
310 thisFunction =
444 thisFunction =
311 case maybeFuncName of
445 case maybeFuncName of
312− C.NoName ->
446+ NoName ->
313 "this function"
447 "this function"
314
448
315− C.FuncName name ->
449+ FuncName name ->
316 "`" <> N.toString name <> "`"
450 "`" <> N.toString name <> "`"
317
451
318− C.CtorName name ->
452+ CtorName name ->
319 "`" <> N.toString name <> "`"
453 "`" <> N.toString name <> "`"
320
454
321− C.OpName op ->
455+ OpName op ->
322 "(" <> N.toString op <> ")"
456 "(" <> N.toString op <> ")"
323
457
324 in
458 in
@@ -345,38 +479,38 @@ toMismatchReport source localizer exprRegion thing tipe expected =
345 )
479 )
346 )
480 )
347
481
348− C.TooManyArgs maybeName numGivenArgs ->
482+ TooManyArgs maybeName numGivenArgs ->
349− case length (Type.delambda tipe) - 1 of
483+ case countArgs tipe of
350 0 ->
484 0 ->
351 Report.toCodeSnippet source region (Just exprRegion)
485 Report.toCodeSnippet source region (Just exprRegion)
352 (
486 (
353 H.reflow $
487 H.reflow $
354 case maybeName of
488 case maybeName of
355− C.NoName ->
489+ NoName ->
356 "You are giving " <> H.args numGivenArgs <> " to something that is not a function!"
490 "You are giving " <> H.args numGivenArgs <> " to something that is not a function!"
357
491
358− C.FuncName name ->
492+ FuncName name ->
359 "`" <> N.toString name <> "` is not a function, but you are giving it " <> H.args numGivenArgs <> "!"
493 "`" <> N.toString name <> "` is not a function, but you are giving it " <> H.args numGivenArgs <> "!"
360
494
361− C.CtorName name ->
495+ CtorName name ->
362 "`" <> N.toString name <> "` is not a function, but you are giving it " <> H.args numGivenArgs <> "!"
496 "`" <> N.toString name <> "` is not a function, but you are giving it " <> H.args numGivenArgs <> "!"
363
497
364− C.OpName op ->
498+ OpName op ->
365 "(" <> N.toString op <> ") is not a function, but you are giving it " <> H.args numGivenArgs <> "!"
499 "(" <> N.toString op <> ") is not a function, but you are giving it " <> H.args numGivenArgs <> "!"
366 ,
500 ,
367 typeComparison localizer tipe expectedType
501 typeComparison localizer tipe expectedType
368 (
502 (
369 case maybeName of
503 case maybeName of
370− C.NoName ->
504+ NoName ->
371 "It is a value of type:"
505 "It is a value of type:"
372
506
373− C.FuncName name ->
507+ FuncName name ->
374 "`" <> N.toString name <> "` is a value of type:"
508 "`" <> N.toString name <> "` is a value of type:"
375
509
376− C.CtorName name ->
510+ CtorName name ->
377 "`" <> N.toString name <> "` is a constructor of type:"
511 "`" <> N.toString name <> "` is a constructor of type:"
378
512
379− C.OpName op ->
513+ OpName op ->
380 "(" <> N.toString op <> ") is a value of type:"
514 "(" <> N.toString op <> ") is a value of type:"
381 ,
515 ,
382 "But you are giving it " <> H.args numGivenArgs <> " as if its type was:"
516 "But you are giving it " <> H.args numGivenArgs <> " as if its type was:"
@@ -390,16 +524,16 @@ toMismatchReport source localizer exprRegion thing tipe expected =
390 let
524 let
391 thisFunction =
525 thisFunction =
392 case maybeName of
526 case maybeName of
393− C.NoName ->
527+ NoName ->
394 "This function"
528 "This function"
395
529
396− C.FuncName name ->
530+ FuncName name ->
397 "The `" <> N.toString name <> "` function"
531 "The `" <> N.toString name <> "` function"
398
532
399− C.CtorName name ->
533+ CtorName name ->
400 "The `" <> N.toString name <> "` constructor"
534 "The `" <> N.toString name <> "` constructor"
401
535
402− C.OpName op ->
536+ OpName op ->
403 "The (" <> N.toString op <> ") function"
537 "The (" <> N.toString op <> ") function"
404 in
538 in
405 Report.toCodeSnippet source region (Just exprRegion)
539 Report.toCodeSnippet source region (Just exprRegion)
@@ -422,10 +556,10 @@ toMismatchReport source localizer exprRegion thing tipe expected =
422 )
556 )
423 )
557 )
424
558
425− C.RecordAccess field ->
559+ RecordAccess field ->
426 Report.toCodeSnippet source region (Just exprRegion) $
560 Report.toCodeSnippet source region (Just exprRegion) $
427− case Type.deepDealias tipe of
561+ case error "TODO figure out record things" tipe of
428− Can.TRecord _ _ ->
562+ Record _ _ ->
429 (
563 (
430 H.reflow $
564 H.reflow $
431 "This record does not have a `" <> N.toString field <> "` field:"
565 "This record does not have a `" <> N.toString field <> "` field:"
@@ -459,7 +593,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =
459 ]
593 ]
460 )
594 )
461
595
462− Can.TLambda _ _ ->
596+ Lambda _ _ ->
463 (
597 (
464 H.reflow $
598 H.reflow $
465 "I cannot access field `" <> N.toString field <> "` of this " <> whatever <> ":"
599 "I cannot access field `" <> N.toString field <> "` of this " <> whatever <> ":"
@@ -484,9 +618,9 @@ toMismatchReport source localizer exprRegion thing tipe expected =
484 ]
618 ]
485 )
619 )
486
620
487− C.RecordUpdate ->
621+ RecordUpdate ->
488− case Type.deepDealias tipe of
622+ case error "TODO figure out record things" tipe of
489− Can.TRecord _ _ ->
623+ Record _ _ ->
490 Report.toCodeSnippet source region Nothing
624 Report.toCodeSnippet source region Nothing
491 (
625 (
492 H.reflow $
626 H.reflow $
@@ -507,15 +641,29 @@ toMismatchReport source localizer exprRegion thing tipe expected =
507 ]
641 ]
508 )
642 )
509
643
510− C.Destructure ->
644+ Destructure ->
511 error "TODO Destructure"
645 error "TODO Destructure"
512
646
513
647
514
648
649+-- COUNT ARGS
650+
651+
652+countArgs :: Type -> Int
653+countArgs tipe =
654+ case tipe of
655+ Lambda _ stuff ->
656+ length stuff
657+
658+ _ ->
659+ 0
660+
661+
662+
515-- OP LEFT
663-- OP LEFT
516
664
517
665
518−opLeftToDocs :: Type.Localizer -> Thing -> N.Name -> Can.Type -> Can.Type -> (H.Doc, H.Doc)
666+opLeftToDocs :: Localizer -> Thing -> N.Name -> Type -> Type -> (H.Doc, H.Doc)
519opLeftToDocs localizer thing op tipe expectedType =
667opLeftToDocs localizer thing op tipe expectedType =
520 case op of
668 case op of
521 "+"
669 "+"
@@ -533,10 +681,10 @@ opLeftToDocs localizer thing op tipe expectedType =
533 "//" -> badIDiv localizer "left" tipe
681 "//" -> badIDiv localizer "left" tipe
534 "&&" -> badBool localizer "&&" "left" tipe
682 "&&" -> badBool localizer "&&" "left" tipe
535 "||" -> badBool localizer "||" "left" tipe
683 "||" -> badBool localizer "||" "left" tipe
536− "<" -> badCompArg localizer thing "<" "left" tipe
684+ "<" -> badCompLeft localizer thing "<" "left" tipe
537− ">" -> badCompArg localizer thing ">" "left" tipe
685+ ">" -> badCompLeft localizer thing ">" "left" tipe
538− "<=" -> badCompArg localizer thing "<=" "left" tipe
686+ "<=" -> badCompLeft localizer thing "<=" "left" tipe
539− ">=" -> badCompArg localizer thing ">=" "left" tipe
687+ ">=" -> badCompLeft localizer thing ">=" "left" tipe
540
688
541 "<|" ->
689 "<|" ->
542 ( "The left side of (<|) needs to be a function so I can pipe arguments to it!"
690 ( "The left side of (<|) needs to be a function so I can pipe arguments to it!"
@@ -548,7 +696,7 @@ opLeftToDocs localizer thing op tipe expectedType =
548 , error "TODO"
696 , error "TODO"
549 {-
697 {-
550 case category of
698 case category of
551− C.Call ->
699+ Call ->
552 "Maybe you gave " <> funcName <> " too many arguments already?"
700 "Maybe you gave " <> funcName <> " too many arguments already?"
553
701
554 _ ->
702 _ ->
@@ -577,44 +725,53 @@ opLeftToDocs localizer thing op tipe expectedType =
577-- OP RIGHT
725-- OP RIGHT
578
726
579
727
728+data RightDocs
729+ = EmphBoth (H.Doc, H.Doc)
730+ | EmphRight (H.Doc, H.Doc)
731+
732+
580−opRightToDocs :: Type.Localizer -> Thing -> N.Name -> Can.Type -> Can.Type -> (H.Doc, H.Doc)
733+opRightToDocs :: Localizer -> Thing -> N.Name -> Type -> Type -> RightDocs
581opRightToDocs localizer thing op tipe expectedType =
734opRightToDocs localizer thing op tipe expectedType =
582 case op of
735 case op of
583 "+"
736 "+"
584 | isInt tipe -> badCast op FloatInt
737 | isInt tipe -> badCast op FloatInt
585 | isFloat tipe -> badCast op IntFloat
738 | isFloat tipe -> badCast op IntFloat
586− | isString tipe -> badStringAdd
739+ | isString tipe -> EmphRight $ badStringAdd
587− | isList tipe -> badListAdd localizer "right" tipe
740+ | isList tipe -> EmphRight $ badListAdd localizer "right" tipe
588− | otherwise -> badMath localizer "Addition" "right" "+" tipe []
741+ | otherwise -> EmphRight $ badMath localizer "Addition" "right" "+" tipe []
589
742
590 "*"
743 "*"
591 | isInt tipe -> badCast op FloatInt
744 | isInt tipe -> badCast op FloatInt
592 | isFloat tipe -> badCast op IntFloat
745 | isFloat tipe -> badCast op IntFloat
593− | isList tipe -> badListMul localizer "right" tipe
746+ | isList tipe -> EmphRight $ badListMul localizer "right" tipe
594− | otherwise -> badMath localizer "Multiplication" "right" "*" tipe []
747+ | otherwise -> EmphRight $ badMath localizer "Multiplication" "right" "*" tipe []
595
748
596 "-"
749 "-"
597 | isInt tipe -> badCast op FloatInt
750 | isInt tipe -> badCast op FloatInt
598 | isFloat tipe -> badCast op IntFloat
751 | isFloat tipe -> badCast op IntFloat
599− | otherwise -> badMath localizer "Subtraction" "right" "-" tipe []
752+ | otherwise -> EmphRight $ badMath localizer "Subtraction" "right" "-" tipe []
600
753
601 "^"
754 "^"
602 | isInt tipe -> badCast op FloatInt
755 | isInt tipe -> badCast op FloatInt
603 | isFloat tipe -> badCast op IntFloat
756 | isFloat tipe -> badCast op IntFloat
604− | otherwise -> badMath localizer "Exponentiation" "right" "^" tipe []
757+ | otherwise -> EmphRight $ badMath localizer "Exponentiation" "right" "^" tipe []
605−
758+
606− "/" -> badFDiv localizer "right" tipe
759+ "/" -> EmphRight $ badFDiv localizer "right" tipe
607− "//" -> badIDiv localizer "right" tipe
760+ "//" -> EmphRight $ badIDiv localizer "right" tipe
608− "&&" -> badBool localizer "&&" "right" tipe
761+ "&&" -> EmphRight $ badBool localizer "&&" "right" tipe
609− "||" -> badBool localizer "||" "right" tipe
762+ "||" -> EmphRight $ badBool localizer "||" "right" tipe
610− "<" -> badCompRight localizer thing "<" tipe expectedType
763+ "<" -> badCompRight localizer "<" tipe expectedType
611− ">" -> badCompRight localizer thing ">" tipe expectedType
764+ ">" -> badCompRight localizer ">" tipe expectedType
612− "<=" -> badCompRight localizer thing "<=" tipe expectedType
765+ "<=" -> badCompRight localizer "<=" tipe expectedType
613− ">=" -> badCompRight localizer thing ">=" tipe expectedType
766+ ">=" -> badCompRight localizer ">=" tipe expectedType
614 "==" -> badEquality localizer "==" tipe expectedType
767 "==" -> badEquality localizer "==" tipe expectedType
615 "/=" -> badEquality localizer "/=" tipe expectedType
768 "/=" -> badEquality localizer "/=" tipe expectedType
616
769
770+ "::" ->
771+ error "TODO see if people want ++ instead?"
772+
617 "<|" ->
773 "<|" ->
774+ EmphRight
618 (
775 (
619 H.reflow $
776 H.reflow $
620 "I cannot pipe this " <> whatever <> " in as the final argument:"
777 "I cannot pipe this " <> whatever <> " in as the final argument:"
@@ -633,7 +790,8 @@ opRightToDocs localizer thing op tipe expectedType =
633
790
634 "|>" ->
791 "|>" ->
635 case (tipe, expectedType) of
792 case (tipe, expectedType) of
636− (Can.TLambda expectedArgType _, Can.TLambda argType _) ->
793+ (Lambda expectedArgType _, Lambda argType _) ->
794+ EmphRight
637 (
795 (
638 "I cannot pipe the argument through to this function:"
796 "I cannot pipe the argument through to this function:"
639 ,
797 ,
@@ -647,10 +805,10 @@ opRightToDocs localizer thing op tipe expectedType =
647 Nothing ->
805 Nothing ->
648 "But (|>) is piping it a function that expects the next argument to be:"
806 "But (|>) is piping it a function that expects the next argument to be:"
649
807
650− Just (C.FuncName name) ->
808+ Just (FuncName name) ->
651 "But (|>) is piping it to `" <> N.toString name <> "` which expects the next argument to be:"
809 "But (|>) is piping it to `" <> N.toString name <> "` which expects the next argument to be:"
652
810
653− Just (C.OpName op) ->
811+ Just (OpName op) ->
654 "But (|>) is piping it to (" <> N.toString op <> ") which expects the next argument to be:"
812 "But (|>) is piping it to (" <> N.toString op <> ") which expects the next argument to be:"
655 -}
813 -}
656 ,
814 ,
@@ -661,6 +819,7 @@ opRightToDocs localizer thing op tipe expectedType =
661 )
819 )
662
820
663 _ ->
821 _ ->
822+ EmphRight
664 (
823 (
665 "The right side of (|>) needs to be a function so I can pipe arguments to it!"
824 "The right side of (|>) needs to be a function so I can pipe arguments to it!"
666 ,
825 ,
@@ -681,6 +840,7 @@ opRightToDocs localizer thing op tipe expectedType =
681 )
840 )
682
841
683 _ ->
842 _ ->
843+ EmphRight
684 (
844 (
685 H.reflow $
845 H.reflow $
686 "The right argument of (" <> N.toString op <> ") is causing problems."
846 "The right argument of (" <> N.toString op <> ") is causing problems."
@@ -702,40 +862,40 @@ opRightToDocs localizer thing op tipe expectedType =
702
862
703
863
704
864
705−isInt :: Can.Type -> Bool
865+isInt :: Type -> Bool
706isInt tipe =
866isInt tipe =
707 case tipe of
867 case tipe of
708− Can.TType home name [] ->
868+ Type home name [] ->
709 home == ModuleName.basics && name == N.int
869 home == ModuleName.basics && name == N.int
710
870
711 _ ->
871 _ ->
712 False
872 False
713
873
714
874
715−isFloat :: Can.Type -> Bool
875+isFloat :: Type -> Bool
716isFloat tipe =
876isFloat tipe =
717 case tipe of
877 case tipe of
718− Can.TType home name [] ->
878+ Type home name [] ->
719 home == ModuleName.basics && name == N.float
879 home == ModuleName.basics && name == N.float
720
880
721 _ ->
881 _ ->
722 False
882 False
723
883
724
884
725−isString :: Can.Type -> Bool
885+isString :: Type -> Bool
726isString tipe =
886isString tipe =
727 case tipe of
887 case tipe of
728− Can.TType home name [] ->
888+ Type home name [] ->
729 home == ModuleName.string && name == N.string
889 home == ModuleName.string && name == N.string
730
890
731 _ ->
891 _ ->
732 False
892 False
733
893
734
894
735−isList :: Can.Type -> Bool
895+isList :: Type -> Bool
736isList tipe =
896isList tipe =
737 case tipe of
897 case tipe of
738− Can.TType home name [_] ->
898+ Type home name [_] ->
739 home == ModuleName.list && name == N.list
899 home == ModuleName.list && name == N.list
740
900
741 _ ->
901 _ ->
@@ -754,25 +914,26 @@ whatever =
754data ThisThenThat = FloatInt | IntFloat
914data ThisThenThat = FloatInt | IntFloat
755
915
756
916
757−badCast :: N.Name -> ThisThenThat -> (H.Doc, H.Doc)
917+badCast :: N.Name -> ThisThenThat -> RightDocs
758badCast op thisThenThat =
918badCast op thisThenThat =
759− (
919+ EmphBoth
920+ (
760− H.text $
921+ H.text $
761− "I need both sides of (" <> N.toString op <> ") to be the exact same type. Both Int or both Float."
922+ "I need both sides of (" <> N.toString op <> ") to be the exact same type. Both Int or both Float."
762− ,
923+ ,
763− let
924+ let
764− anInt = ["an", H.dullyellow "Int"]
925+ anInt = ["an", H.dullyellow "Int"]
765− aFloat = ["a", H.dullyellow "Float"]
926+ aFloat = ["a", H.dullyellow "Float"]
766− toFloat = H.green "toFloat"
927+ toFloat = H.green "toFloat"
767− round = H.green "round"
928+ round = H.green "round"
768− in
929+ in
769− case thisThenThat of
930+ case thisThenThat of
770− FloatInt ->
931+ FloatInt ->
771− badCastHelp aFloat anInt round toFloat
932+ badCastHelp aFloat anInt round toFloat
772−
933+
773− IntFloat ->
934+ IntFloat ->
774− badCastHelp anInt aFloat toFloat round
935+ badCastHelp anInt aFloat toFloat round
775− )
936+ )
776
937
777
938
778badCastHelp :: [H.Doc] -> [H.Doc] -> H.Doc -> H.Doc -> H.Doc
939badCastHelp :: [H.Doc] -> [H.Doc] -> H.Doc -> H.Doc -> H.Doc
@@ -808,7 +969,7 @@ badStringAdd =
808 )
969 )
809
970
810
971
811−badListAdd :: Type.Localizer -> String -> Can.Type -> (H.Doc, H.Doc)
972+badListAdd :: Localizer -> String -> Type -> (H.Doc, H.Doc)
812badListAdd localizer direction tipe =
973badListAdd localizer direction tipe =
813 (
974 (
814 "I cannot do addition with lists:"
975 "I cannot do addition with lists:"
@@ -827,7 +988,7 @@ badListAdd localizer direction tipe =
827 )
988 )
828
989
829
990
830−badListMul :: Type.Localizer -> String -> Can.Type -> (H.Doc, H.Doc)
991+badListMul :: Localizer -> String -> Type -> (H.Doc, H.Doc)
831badListMul localizer direction tipe =
992badListMul localizer direction tipe =
832 badMath localizer "Multiplication" direction "*" tipe
993 badMath localizer "Multiplication" direction "*" tipe
833 [
994 [
@@ -839,7 +1000,7 @@ badListMul localizer direction tipe =
839 ]
1000 ]
840
1001
841
1002
842−badMath :: Type.Localizer -> String -> String -> String -> Can.Type -> [H.Doc] -> (H.Doc, H.Doc)
1003+badMath :: Localizer -> String -> String -> String -> Type -> [H.Doc] -> (H.Doc, H.Doc)
843badMath localizer operation direction op tipe otherHints =
1004badMath localizer operation direction op tipe otherHints =
844 (
1005 (
845 H.reflow $
1006 H.reflow $
@@ -859,7 +1020,7 @@ badMath localizer operation direction op tipe otherHints =
859 )
1020 )
860
1021
861
1022
862−badFDiv :: Type.Localizer -> H.Doc -> Can.Type -> (H.Doc, H.Doc)
1023+badFDiv :: Localizer -> H.Doc -> Type -> (H.Doc, H.Doc)
863badFDiv localizer direction tipe =
1024badFDiv localizer direction tipe =
864 (
1025 (
865 H.reflow $
1026 H.reflow $
@@ -892,7 +1053,7 @@ badFDiv localizer direction tipe =
892 )
1053 )
893
1054
894
1055
895−badIDiv :: Type.Localizer -> H.Doc -> Can.Type -> (H.Doc, H.Doc)
1056+badIDiv :: Localizer -> H.Doc -> Type -> (H.Doc, H.Doc)
896badIDiv localizer direction tipe =
1057badIDiv localizer direction tipe =
897 (
1058 (
898 H.reflow $
1059 H.reflow $
@@ -931,7 +1092,7 @@ badIDiv localizer direction tipe =
931-- BAD BOOLS
1092-- BAD BOOLS
932
1093
933
1094
934−badBool :: Type.Localizer -> H.Doc -> H.Doc -> Can.Type -> (H.Doc, H.Doc)
1095+badBool :: Localizer -> H.Doc -> H.Doc -> Type -> (H.Doc, H.Doc)
935badBool localizer op direction tipe =
1096badBool localizer op direction tipe =
936 (
1097 (
937 H.reflow $
1098 H.reflow $
@@ -954,18 +1115,8 @@ badBool localizer op direction tipe =
954-- BAD COMPARISON
1115-- BAD COMPARISON
955
1116
956
1117
957−badCompRight :: Type.Localizer -> Thing -> String -> Can.Type -> Can.Type -> (H.Doc, H.Doc)
958−badCompRight localizer thing op tipe expectedType =
959− case tipe of
960− Can.TVar name | N.startsWith "comparable" name ->
961− badCompArg localizer thing op "right" tipe
962−
963− _ ->
964− badCompMix localizer op tipe expectedType
965−
966−
967−badCompArg :: Type.Localizer -> Thing -> String -> String -> Can.Type -> (H.Doc, H.Doc)
1118+badCompLeft :: Localizer -> Thing -> String -> String -> Type -> (H.Doc, H.Doc)
968−badCompArg localizer thing op direction tipe =
1119+badCompLeft localizer thing op direction tipe =
969 (
1120 (
970 H.reflow $
1121 H.reflow $
971 "I cannot do a comparison with this value:"
1122 "I cannot do a comparison with this value:"
@@ -988,51 +1139,81 @@ badCompArg localizer thing op direction tipe =
988 )
1139 )
989
1140
990
1141
991−badCompMix :: Type.Localizer -> String -> Can.Type -> Can.Type -> (H.Doc, H.Doc)
1142+badCompRight :: Localizer -> String -> Type -> Type -> RightDocs
992−badCompMix localizer op tipe expectedType =
1143+badCompRight localizer op tipe expectedType =
1144+ EmphBoth
993− (
1145+ (
994− H.reflow $
1146+ H.reflow $
995− "I need both sides of (" <> op <> ") to be the same type:"
1147+ "I need both sides of (" <> op <> ") to be the same type:"
996− ,
1148+ ,
997− typeComparison localizer expectedType tipe
1149+ typeComparison localizer expectedType tipe
998− (
1150+ (
999− "The left side of is:"
1151+ "The left side of is:"
1000− ,
1152+ ,
1001− "But the right side is:"
1153+ "But the right side is:"
1002− ,
1154+ ,
1003− [ H.reflow $
1155+ [ H.reflow $
1004− "I cannot compare different types though! Which side of (" <> op <> ") is the problem?"
1156+ "I cannot compare different types though! Which side of (" <> op <> ") is the problem?"
1005− ]
1157+ ]
1006− )
1158+ )
1007− )
1159+ )
1008
1160
1009
1161
1010
1162
1011-- BAD EQUALITY
1163-- BAD EQUALITY
1012
1164
1013
1165
1014−badEquality :: Type.Localizer -> String -> Can.Type -> Can.Type -> (H.Doc, H.Doc)
1166+badEquality :: Localizer -> String -> Type -> Type -> RightDocs
1015badEquality localizer op tipe expectedType =
1167badEquality localizer op tipe expectedType =
1168+ EmphBoth
1016− (
1169+ (
1017− H.reflow $
1170+ H.reflow $
1018− "I need both sides of (" <> op <> ") to be the same type:"
1171+ "I need both sides of (" <> op <> ") to be the same type:"
1019− ,
1172+ ,
1020− typeComparison localizer expectedType tipe
1173+ typeComparison localizer expectedType tipe
1021− (
1174+ (
1022− "The left side of is:"
1175+ "The left side of is:"
1023− ,
1176+ ,
1024− "But the right side is:"
1177+ "But the right side is:"
1025− ,
1178+ ,
1026− if isFloat tipe || isFloat expectedType then
1179+ if isFloat tipe || isFloat expectedType then
1027− [ H.toSimpleNote $
1180+ [ H.toSimpleNote $
1028− "Equality on floats is not 100% reliable due to the design of IEEE 754. I\
1181+ "Equality on floats is not 100% reliable due to the design of IEEE 754. I\
1029− \ recommend a check like (abs (x - y) < 0.0001) instead."
1182+ \ recommend a check like (abs (x - y) < 0.0001) instead."
1030− ]
1183+ ]
1031− else
1184+ else
1032− [ H.reflow $
1185+ [ H.reflow $
1033− "Different types can never be equal though! Which side is messed up?"
1186+ "Different types can never be equal though! Which side is messed up?"
1034− ]
1187+ ]
1035−-- else
1188+-- else
1036−-- error "TODO detect problems here instead?"
1189+-- error "TODO detect problems here instead?"
1037− )
1190+ )
1038− )
1191+ )
1192+
1193+
1194+
1195+-- DIFF TYPES
1196+
1197+
1198+type Localizer = Map.Map N.Name ()
1199+
1200+
1201+typeComparison :: Localizer -> Type -> Type -> ( String, String, [H.Doc] ) -> H.Doc
1202+typeComparison localizer actual expected ( iAmSeeing, insteadOf, soHereAreSomeThoughts ) =
1203+ let
1204+ (actualDoc, expectedDoc) =
1205+ error "TODO diff" localizer actual expected
1206+ in
1207+ H.stack $
1208+ [ H.reflow iAmSeeing
1209+ , H.indent 4 actualDoc
1210+ , H.reflow insteadOf
1211+ , H.indent 4 expectedDoc
1212+ ]
1213+ ++ soHereAreSomeThoughts
1214+
1215+
1216+indentType :: Localizer -> Type -> H.Doc
1217+indentType localizer tipe =
1218+ H.indent 4 (H.dullyellow (error "TODO Type.toDoc" localizer tipe))
1219+
src/Type/Constrain/Expression.hs+10−9
@@ -15,8 +15,9 @@ import qualified AST.Utils.Shader as Shader
15import qualified Data.Index as Index
15import qualified Data.Index as Index
16import qualified Elm.Name as N
16import qualified Elm.Name as N
17import qualified Reporting.Annotation as A
17import qualified Reporting.Annotation as A
18+import qualified Reporting.Error.Type as E
19+import Reporting.Error.Type (Expected(..), Context(..), SubContext(..), MaybeName(..), Category(..), PExpected(..), PContext(..))
18import qualified Reporting.Region as R
20import qualified Reporting.Region as R
19−import Type.Constraint as C
20import qualified Type.Constrain.Pattern as Pattern
21import qualified Type.Constrain.Pattern as Pattern
21import qualified Type.Instantiate as Instantiate
22import qualified Type.Instantiate as Instantiate
22import Type.Type as Type hiding (Descriptor(..))
23import Type.Type as Type hiding (Descriptor(..))
@@ -69,7 +70,7 @@ constrain rtv (A.At region expression) expected =
69
70
70 Can.Int _ ->
71 Can.Int _ ->
71 do var <- mkFlexNumber
72 do var <- mkFlexNumber
72− return $ exists [var] $ CEqual region C.Number (VarN var) expected
73+ return $ exists [var] $ CEqual region E.Number (VarN var) expected
73
74
74 Can.Float _ ->
75 Can.Float _ ->
75 return $ CEqual region Float Type.float expected
76 return $ CEqual region Float Type.float expected
@@ -81,7 +82,7 @@ constrain rtv (A.At region expression) expected =
81 do numberVar <- mkFlexNumber
82 do numberVar <- mkFlexNumber
82 let numberType = VarN numberVar
83 let numberType = VarN numberVar
83 numberCon <- constrain rtv expr (FromContext region Negate numberType)
84 numberCon <- constrain rtv expr (FromContext region Negate numberType)
84− let negateCon = CEqual region C.Number numberType expected
85+ let negateCon = CEqual region E.Number numberType expected
85 return $ exists [numberVar] $ CAnd [ numberCon, negateCon ]
86 return $ exists [numberVar] $ CAnd [ numberCon, negateCon ]
86
87
87 Can.Binop op _ _ annotation leftExpr rightExpr ->
88 Can.Binop op _ _ annotation leftExpr rightExpr ->
@@ -143,7 +144,7 @@ constrain rtv (A.At region expression) expected =
143 constrainRecord rtv region fields expected
144 constrainRecord rtv region fields expected
144
145
145 Can.Unit ->
146 Can.Unit ->
146− return $ CEqual region Unit UnitN expected
147+ return $ CEqual region UnitExpr UnitN expected
147
148
148 Can.Tuple a b maybeC ->
149 Can.Tuple a b maybeC ->
149 constrainTuple rtv region a b maybeC expected
150 constrainTuple rtv region a b maybeC expected
@@ -173,7 +174,7 @@ constrainLambda rtv region args body expected =
173 , _headerCon = CAnd (reverse revCons)
174 , _headerCon = CAnd (reverse revCons)
174 , _bodyCon = bodyCon
175 , _bodyCon = bodyCon
175 }
176 }
176− , CEqual region Lambda tipe expected
177+ , CEqual region LambdaExpr tipe expected
177 ]
178 ]
178
179
179
180
@@ -402,7 +403,7 @@ constrainRecord rtv region fields expected =
402
403
403 let getType (_, t, _) = t
404 let getType (_, t, _) = t
404 let recordType = RecordN (Map.map getType dict) EmptyRecordN
405 let recordType = RecordN (Map.map getType dict) EmptyRecordN
405− let recordCon = CEqual region Record recordType expected
406+ let recordCon = CEqual region RecordExpr recordType expected
406
407
407 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
408 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
408 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
409 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
@@ -436,7 +437,7 @@ constrainUpdate rtv region expr fields expected =
436
437
437 let getType (_, t, _) = t
438 let getType (_, t, _) = t
438 let newRecordType = RecordN (Map.map getType newDict) sharedType
439 let newRecordType = RecordN (Map.map getType newDict) sharedType
439− let newCon = CEqual region Record newRecordType expected
440+ let newCon = CEqual region RecordExpr newRecordType expected
440
441
441 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
442 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
442 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
443 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
@@ -461,7 +462,7 @@ constrainTuple rtv region a b maybeC expected =
461 case maybeC of
462 case maybeC of
462 Nothing ->
463 Nothing ->
463 do let tupleType = TupleN aType bType Nothing
464 do let tupleType = TupleN aType bType Nothing
464− let tupleCon = CEqual region Tuple tupleType expected
465+ let tupleCon = CEqual region TupleExpr tupleType expected
465 return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
466 return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
466
467
467 Just c ->
468 Just c ->
@@ -471,7 +472,7 @@ constrainTuple rtv region a b maybeC expected =
471 cCon <- constrain rtv c (NoExpectation cType)
472 cCon <- constrain rtv c (NoExpectation cType)
472
473
473 let tupleType = TupleN aType bType (Just cType)
474 let tupleType = TupleN aType bType (Just cType)
474− let tupleCon = CEqual region Tuple tupleType expected
475+ let tupleCon = CEqual region TupleExpr tupleType expected
475
476
476 return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
477 return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
477
478
src/Type/Constrain/Module.hs+9−9
@@ -12,11 +12,11 @@ import qualified AST.Canonical as Can
12import qualified AST.Module.Name as ModuleName
12import qualified AST.Module.Name as ModuleName
13import qualified Elm.Name as N
13import qualified Elm.Name as N
14import qualified Reporting.Annotation as A
14import qualified Reporting.Annotation as A
15+import qualified Reporting.Error.Type as E
15import qualified Reporting.Region as R
16import qualified Reporting.Region as R
16−import Type.Constraint
17import qualified Type.Constrain.Expression as Expr
17import qualified Type.Constrain.Expression as Expr
18import qualified Type.Instantiate as Instantiate
18import qualified Type.Instantiate as Instantiate
19−import Type.Type (Type(..), (==>), mkFlexVar, never)
19+import Type.Type (Type(..), Constraint(..), (==>), mkFlexVar, never)
20
20
21
21
22
22
@@ -140,12 +140,12 @@ constrainEffects home r0 r1 r2 manager =
140
140
141 let effectCons =
141 let effectCons =
142 CAnd
142 CAnd
143− [ CLocal r0 "init" (NoExpectation (task state0))
143+ [ CLocal r0 "init" (E.NoExpectation (task state0))
144− , CLocal r1 "onEffects" (NoExpectation onEffects)
144+ , CLocal r1 "onEffects" (E.NoExpectation onEffects)
145− , CLocal r2 "onSelfMsg" (NoExpectation onSelfMsg)
145+ , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg)
146− , CEqual r1 Effects state0 (NoExpectation state1)
146+ , CEqual r1 E.Effects state0 (E.NoExpectation state1)
147− , CEqual r2 Effects state0 (NoExpectation state2)
147+ , CEqual r2 E.Effects state0 (E.NoExpectation state2)
148− , CEqual r2 Effects self1 (NoExpectation self2)
148+ , CEqual r2 E.Effects self1 (E.NoExpectation self2)
149 ]
149 ]
150
150
151 CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
151 CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
@@ -181,7 +181,7 @@ checkMap name home tipe constraint =
181 do a <- mkFlexVar
181 do a <- mkFlexVar
182 b <- mkFlexVar
182 b <- mkFlexVar
183 let mapType = toMapType home tipe (VarN a) (VarN b)
183 let mapType = toMapType home tipe (VarN a) (VarN b)
184− let mapCon = CLocal zero name (NoExpectation mapType)
184+ let mapCon = CLocal zero name (E.NoExpectation mapType)
185 return $ CLet [a,b] [] Map.empty mapCon constraint
185 return $ CLet [a,b] [] Map.empty mapCon constraint
186
186
187
187
src/Type/Constrain/Pattern.hs+23−23
@@ -16,8 +16,8 @@ import qualified AST.Module.Name as ModuleName
16import qualified Data.Index as Index
16import qualified Data.Index as Index
17import qualified Elm.Name as N
17import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
19+import qualified Reporting.Error.Type as E
19import qualified Reporting.Region as R
20import qualified Reporting.Region as R
20−import Type.Constraint
21import qualified Type.Instantiate as Instantiate
21import qualified Type.Instantiate as Instantiate
22import Type.Type as T
22import Type.Type as T
23
23
@@ -40,7 +40,7 @@ data State =
40type Header = Map.Map N.Name (A.Located Type)
40type Header = Map.Map N.Name (A.Located Type)
41
41
42
42
43−add :: Can.Pattern -> PExpected Type -> State -> IO State
43+add :: Can.Pattern -> E.PExpected Type -> State -> IO State
44add (A.At region pattern) expectation state =
44add (A.At region pattern) expectation state =
45 case pattern of
45 case pattern of
46 Can.PAnything ->
46 Can.PAnything ->
@@ -55,7 +55,7 @@ add (A.At region pattern) expectation state =
55
55
56 Can.PUnit ->
56 Can.PUnit ->
57 do let (State headers vars revCons) = state
57 do let (State headers vars revCons) = state
58− let unitCon = CPattern region PUnit UnitN expectation
58+ let unitCon = CPattern region E.PUnit UnitN expectation
59 return $ State headers vars (unitCon:revCons)
59 return $ State headers vars (unitCon:revCons)
60
60
61 Can.PTuple a b maybeC ->
61 Can.PTuple a b maybeC ->
@@ -72,7 +72,7 @@ add (A.At region pattern) expectation state =
72 (State headers vars revCons) <-
72 (State headers vars revCons) <-
73 foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)
73 foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)
74
74
75− let listCon = CPattern region PList listType expectation
75+ let listCon = CPattern region E.PList listType expectation
76 return $ State headers (entryVar:vars) (listCon:revCons)
76 return $ State headers (entryVar:vars) (listCon:revCons)
77
77
78 Can.PCons headPattern tailPattern ->
78 Can.PCons headPattern tailPattern ->
@@ -80,14 +80,14 @@ add (A.At region pattern) expectation state =
80 let entryType = VarN entryVar
80 let entryType = VarN entryVar
81 let listType = AppN ModuleName.list N.list [entryType]
81 let listType = AppN ModuleName.list N.list [entryType]
82
82
83− let headExpectation = PNoExpectation entryType
83+ let headExpectation = E.PNoExpectation entryType
84− let tailExpectation = PFromContext region PTail listType
84+ let tailExpectation = E.PFromContext region E.PTail listType
85
85
86 (State headers vars revCons) <-
86 (State headers vars revCons) <-
87 add headPattern headExpectation =<<
87 add headPattern headExpectation =<<
88 add tailPattern tailExpectation state
88 add tailPattern tailExpectation state
89
89
90− let listCon = CPattern region PList listType expectation
90+ let listCon = CPattern region E.PList listType expectation
91 return $ State headers (entryVar:vars) (listCon : revCons)
91 return $ State headers (entryVar:vars) (listCon : revCons)
92
92
93 Can.PRecord fields ->
93 Can.PRecord fields ->
@@ -99,7 +99,7 @@ add (A.At region pattern) expectation state =
99 let recordType = RecordN fieldTypes extType
99 let recordType = RecordN fieldTypes extType
100
100
101 let (State headers vars revCons) = state
101 let (State headers vars revCons) = state
102− let recordCon = CPattern region PRecord recordType expectation
102+ let recordCon = CPattern region E.PRecord recordType expectation
103 return $
103 return $
104 State
104 State
105 { _headers = Map.union headers (Map.map (A.At region) fieldTypes)
105 { _headers = Map.union headers (Map.map (A.At region) fieldTypes)
@@ -109,17 +109,17 @@ add (A.At region pattern) expectation state =
109
109
110 Can.PInt _ ->
110 Can.PInt _ ->
111 do let (State headers vars revCons) = state
111 do let (State headers vars revCons) = state
112− let intCon = CPattern region PInt T.int expectation
112+ let intCon = CPattern region E.PInt T.int expectation
113 return $ State headers vars (intCon:revCons)
113 return $ State headers vars (intCon:revCons)
114
114
115 Can.PStr _ ->
115 Can.PStr _ ->
116 do let (State headers vars revCons) = state
116 do let (State headers vars revCons) = state
117− let strCon = CPattern region PStr T.string expectation
117+ let strCon = CPattern region E.PStr T.string expectation
118 return $ State headers vars (strCon:revCons)
118 return $ State headers vars (strCon:revCons)
119
119
120 Can.PChr _ ->
120 Can.PChr _ ->
121 do let (State headers vars revCons) = state
121 do let (State headers vars revCons) = state
122− let chrCon = CPattern region PChr T.char expectation
122+ let chrCon = CPattern region E.PChr T.char expectation
123 return $ State headers vars (chrCon:revCons)
123 return $ State headers vars (chrCon:revCons)
124
124
125
125
@@ -133,7 +133,7 @@ emptyState =
133 State Map.empty [] []
133 State Map.empty [] []
134
134
135
135
136−addToHeaders :: R.Region -> N.Name -> PExpected Type -> State -> State
136+addToHeaders :: R.Region -> N.Name -> E.PExpected Type -> State -> State
137addToHeaders region name expectation (State headers vars revCons) =
137addToHeaders region name expectation (State headers vars revCons) =
138 let
138 let
139 tipe = getType expectation
139 tipe = getType expectation
@@ -142,11 +142,11 @@ addToHeaders region name expectation (State headers vars revCons) =
142 State newHeaders vars revCons
142 State newHeaders vars revCons
143
143
144
144
145−getType :: PExpected Type -> Type
145+getType :: E.PExpected Type -> Type
146getType expectation =
146getType expectation =
147 case expectation of
147 case expectation of
148− PNoExpectation tipe -> tipe
148+ E.PNoExpectation tipe -> tipe
149− PFromContext _ _ tipe -> tipe
149+ E.PFromContext _ _ tipe -> tipe
150
150
151
151
152
152
@@ -157,7 +157,7 @@ addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO St
157addEntry listRegion tipe state (index, pattern) =
157addEntry listRegion tipe state (index, pattern) =
158 let
158 let
159 expectation =
159 expectation =
160− PFromContext listRegion (PListEntry index) tipe
160+ E.PFromContext listRegion (E.PListEntry index) tipe
161 in
161 in
162 add pattern expectation state
162 add pattern expectation state
163
163
@@ -166,7 +166,7 @@ addEntry listRegion tipe state (index, pattern) =
166-- CONSTRAIN TUPLE
166-- CONSTRAIN TUPLE
167
167
168
168
169−addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PExpected Type -> State -> IO State
169+addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> E.PExpected Type -> State -> IO State
170addTuple region a b maybeC expectation state =
170addTuple region a b maybeC expectation state =
171 do aVar <- mkFlexVar
171 do aVar <- mkFlexVar
172 bVar <- mkFlexVar
172 bVar <- mkFlexVar
@@ -179,7 +179,7 @@ addTuple region a b maybeC expectation state =
179 simpleAdd b bType =<<
179 simpleAdd b bType =<<
180 simpleAdd a aType state
180 simpleAdd a aType state
181
181
182− let tupleCon = CPattern region PTuple (TupleN aType bType Nothing) expectation
182+ let tupleCon = CPattern region E.PTuple (TupleN aType bType Nothing) expectation
183
183
184 return $ State headers (aVar:bVar:vars) (tupleCon:revCons)
184 return $ State headers (aVar:bVar:vars) (tupleCon:revCons)
185
185
@@ -192,21 +192,21 @@ addTuple region a b maybeC expectation state =
192 simpleAdd b bType =<<
192 simpleAdd b bType =<<
193 simpleAdd a aType state
193 simpleAdd a aType state
194
194
195− let tupleCon = CPattern region PTuple (TupleN aType bType (Just cType)) expectation
195+ let tupleCon = CPattern region E.PTuple (TupleN aType bType (Just cType)) expectation
196
196
197 return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)
197 return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)
198
198
199
199
200simpleAdd :: Can.Pattern -> Type -> State -> IO State
200simpleAdd :: Can.Pattern -> Type -> State -> IO State
201simpleAdd pattern patternType state =
201simpleAdd pattern patternType state =
202− add pattern (PNoExpectation patternType) state
202+ add pattern (E.PNoExpectation patternType) state
203
203
204
204
205
205
206-- CONSTRAIN CONSTRUCTORS
206-- CONSTRAIN CONSTRUCTORS
207
207
208
208
209−addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PExpected Type -> State -> IO State
209+addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> E.PExpected Type -> State -> IO State
210addCtor region home typeName typeVarNames ctorName args expectation state =
210addCtor region home typeName typeVarNames ctorName args expectation state =
211 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
211 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
212 let typePairs = map (second VarN) varPairs
212 let typePairs = map (second VarN) varPairs
@@ -216,7 +216,7 @@ addCtor region home typeName typeVarNames ctorName args expectation state =
216 foldM (addCtorArg region ctorName freeVarDict) state args
216 foldM (addCtorArg region ctorName freeVarDict) state args
217
217
218 let ctorType = AppN home typeName (map snd typePairs)
218 let ctorType = AppN home typeName (map snd typePairs)
219− let ctorCon = CPattern region (PCtor ctorName) ctorType expectation
219+ let ctorCon = CPattern region (E.PCtor ctorName) ctorType expectation
220
220
221 return $
221 return $
222 State
222 State
@@ -229,5 +229,5 @@ addCtor region home typeName typeVarNames ctorName args expectation state =
229addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
229addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
230addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
230addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
231 do tipe <- Instantiate.fromSrcType freeVarDict srcType
231 do tipe <- Instantiate.fromSrcType freeVarDict srcType
232− let expectation = PFromContext region (PCtorArg ctorName index) tipe
232+ let expectation = E.PFromContext region (E.PCtorArg ctorName index) tipe
233 add pattern expectation state
233 add pattern expectation state
src/Type/Constraint.hsdeleted−171
@@ -1,171 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Type.Constraint
4− ( Constraint(..)
5− , exists
6− , Expected(..)
7− , Context(..)
8− , SubContext(..)
9− , MaybeName(..)
10− , Category(..)
11− , PExpected(..)
12− , PContext(..)
13− , PCategory(..)
14− , typeReplace
15− , ptypeReplace
16− )
17− where
18−
19−
20−import qualified Data.Map.Strict as Map
21−
22−import qualified AST.Canonical as Can
23−import qualified Data.Index as Index
24−import qualified Elm.Name as N
25−import qualified Reporting.Annotation as A
26−import qualified Reporting.Region as R
27−import Type.Type (Type, Variable)
28−
29−
30−
31−-- CONSTRAINTS
32−
33−
34−data Constraint
35− = CTrue
36− | CSaveTheEnvironment
37− | CEqual R.Region Category Type (Expected Type)
38− | CLocal R.Region N.Name (Expected Type)
39− | CForeign R.Region N.Name Can.Annotation (Expected Type)
40− | CPattern R.Region PCategory Type (PExpected Type)
41− | CAnd [Constraint]
42− | CBranch
43− { _a :: Type
44− , _b :: Type
45− , _eq :: Constraint
46− , _neq :: IO Constraint
47− }
48− | CLet
49− { _rigidVars :: [Variable]
50− , _flexVars :: [Variable]
51− , _header :: Map.Map N.Name (A.Located Type)
52− , _headerCon :: Constraint
53− , _bodyCon :: Constraint
54− }
55−
56−
57−exists :: [Variable] -> Constraint -> Constraint
58−exists flexVars constraint =
59− CLet [] flexVars Map.empty constraint CTrue
60−
61−
62−
63−-- EXPRESSION EXPECTATIONS
64−
65−
66−data Expected tipe
67− = NoExpectation tipe
68− | FromContext R.Region Context tipe
69− | FromAnnotation N.Name Int SubContext tipe
70−
71−
72−data Context
73− = ListEntry Index.ZeroBased
74− | Negate
75− | OpLeft N.Name
76− | OpRight N.Name
77− | IfCondition
78− | IfBranch Index.ZeroBased
79− | CaseBranch Index.ZeroBased
80− | CallArg MaybeName Index.ZeroBased
81− | TooManyArgs MaybeName Int
82− | RecordAccess N.Name
83− | RecordUpdate
84− | Destructure
85−
86−
87−data SubContext
88− = TypedIfBranch Index.ZeroBased
89− | TypedCaseBranch Index.ZeroBased
90− | TypedBody
91−
92−
93−data MaybeName
94− = FuncName N.Name
95− | CtorName N.Name
96− | OpName N.Name
97− | NoName
98−
99−
100−data Category
101− = List
102− | Number
103− | Float
104− | String
105− | Char
106− | If
107− | Case
108− | CallResult MaybeName
109− | Lambda
110− | Accessor N.Name
111− | Access N.Name
112− | Record
113− | Tuple
114− | Unit
115− | Shader
116− | Effects
117−
118−
119−
120−-- PATTERN EXPECTATIONS
121−
122−
123−data PExpected tipe
124− = PNoExpectation tipe
125− | PFromContext R.Region PContext tipe
126−
127−
128−data PContext
129− = PTypedArg N.Name Index.ZeroBased
130− | PCaseMatch Index.ZeroBased
131− | PCtorArg N.Name Index.ZeroBased
132− | PListEntry Index.ZeroBased
133− | PTail
134−
135−
136−data PCategory
137− = PRecord
138− | PUnit
139− | PTuple
140− | PList
141− | PCtor N.Name
142− | PInt
143− | PStr
144− | PChr
145−
146−
147−
148−-- HELPERS
149−
150−
151−typeReplace :: Expected Type -> Can.Type -> Expected Can.Type
152−typeReplace expectation tipe =
153− case expectation of
154− NoExpectation _ ->
155− NoExpectation tipe
156−
157− FromContext region context _ ->
158− FromContext region context tipe
159−
160− FromAnnotation name arity context _ ->
161− FromAnnotation name arity context tipe
162−
163−
164−ptypeReplace :: PExpected Type -> Can.Type -> PExpected Can.Type
165−ptypeReplace expectation tipe =
166− case expectation of
167− PNoExpectation _ ->
168− PNoExpectation tipe
169−
170− PFromContext region context _ ->
171− PFromContext region context tipe
src/Type/Occurs.hs+1−1
@@ -76,5 +76,5 @@ occursHelp seen var foundCycle =
76 Alias _ _ args _ ->
76 Alias _ _ args _ ->
77 foldrM (occursHelp (var:seen)) foundCycle (map snd args)
77 foldrM (occursHelp (var:seen)) foundCycle (map snd args)
78
78
79− Error _ ->
79+ Error ->
80 return foundCycle
80 return foundCycle
src/Type/Solve.hs+17−18
@@ -17,7 +17,6 @@ import qualified Elm.Name as N
17import qualified Reporting.Annotation as A
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Type as Error
18import qualified Reporting.Error.Type as Error
19import qualified Type.Occurs as Occurs
19import qualified Type.Occurs as Occurs
20−import Type.Constraint as Con
21import Type.Type as Type
20import Type.Type as Type
22import qualified Type.Unify as Unify
21import qualified Type.Unify as Unify
23import qualified Type.UnionFind as UF
22import qualified Type.UnionFind as UF
@@ -92,7 +91,7 @@ solve env rank pools state constraint =
92 return $ addError state $
91 return $ addError state $
93 Error.Mismatch
92 Error.Mismatch
94 (Error.BadExpr region category actualType)
93 (Error.BadExpr region category actualType)
95− (Con.typeReplace expectation expectedType)
94+ (Error.typeReplace expectation expectedType)
96
95
97 CLocal region name expectation ->
96 CLocal region name expectation ->
98 do actual <- makeCopy rank pools (env ! name)
97 do actual <- makeCopy rank pools (env ! name)
@@ -108,7 +107,7 @@ solve env rank pools state constraint =
108 return $ addError state $
107 return $ addError state $
109 Error.Mismatch
108 Error.Mismatch
110 (Error.BadLocal region name actualType)
109 (Error.BadLocal region name actualType)
111− (Con.typeReplace expectation expectedType)
110+ (Error.typeReplace expectation expectedType)
112
111
113 CForeign region name (Can.Forall freeVars srcType) expectation ->
112 CForeign region name (Can.Forall freeVars srcType) expectation ->
114 do actual <- srcTypeToVariable rank pools freeVars srcType
113 do actual <- srcTypeToVariable rank pools freeVars srcType
@@ -124,7 +123,7 @@ solve env rank pools state constraint =
124 return $ addError state $
123 return $ addError state $
125 Error.Mismatch
124 Error.Mismatch
126 (Error.BadForeign region name actualType)
125 (Error.BadForeign region name actualType)
127− (Con.typeReplace expectation expectedType)
126+ (Error.typeReplace expectation expectedType)
128
127
129 CPattern region category tipe expectation ->
128 CPattern region category tipe expectation ->
130 do actual <- typeToVariable rank pools tipe
129 do actual <- typeToVariable rank pools tipe
@@ -139,7 +138,7 @@ solve env rank pools state constraint =
139 do introduce rank pools vars
138 do introduce rank pools vars
140 return $ addError state $
139 return $ addError state $
141 Error.BadPattern region category actualType
140 Error.BadPattern region category actualType
142− (Con.ptypeReplace expectation expectedType)
141+ (Error.ptypeReplace expectation expectedType)
143
142
144 CAnd constraints ->
143 CAnd constraints ->
145 foldM (solve env rank pools) state constraints
144 foldM (solve env rank pools) state constraints
@@ -225,28 +224,28 @@ isGeneric var =
225-- EXPECTATIONS TO VARIABLE
224-- EXPECTATIONS TO VARIABLE
226
225
227
226
228−expectedToVariable :: Int -> Pools -> Expected Type -> IO Variable
227+expectedToVariable :: Int -> Pools -> Error.Expected Type -> IO Variable
229expectedToVariable rank pools expectation =
228expectedToVariable rank pools expectation =
230 typeToVariable rank pools $
229 typeToVariable rank pools $
231 case expectation of
230 case expectation of
232− NoExpectation tipe ->
231+ Error.NoExpectation tipe ->
233 tipe
232 tipe
234
233
235− FromContext _ _ tipe ->
234+ Error.FromContext _ _ tipe ->
236 tipe
235 tipe
237
236
238− FromAnnotation _ _ _ tipe ->
237+ Error.FromAnnotation _ _ _ tipe ->
239 tipe
238 tipe
240
239
241
240
242−patternExpectationToVariable :: Int -> Pools -> PExpected Type -> IO Variable
241+patternExpectationToVariable :: Int -> Pools -> Error.PExpected Type -> IO Variable
243patternExpectationToVariable rank pools expectation =
242patternExpectationToVariable rank pools expectation =
244 typeToVariable rank pools $
243 typeToVariable rank pools $
245 case expectation of
244 case expectation of
246− PNoExpectation tipe ->
245+ Error.PNoExpectation tipe ->
247 tipe
246 tipe
248
247
249− PFromContext _ _ tipe ->
248+ Error.PFromContext _ _ tipe ->
250 tipe
249 tipe
251
250
252
251
@@ -268,10 +267,10 @@ occurs state (_name, A.At _region variable) =
268 do hasOccurred <- Occurs.occurs variable
267 do hasOccurred <- Occurs.occurs variable
269 if hasOccurred
268 if hasOccurred
270 then
269 then
271− do overallType <- Type.toSrcType variable
270+ do errorType <- Type.toErrorType variable
272 (Descriptor _ rank mark copy) <- UF.get variable
271 (Descriptor _ rank mark copy) <- UF.get variable
273− UF.set variable (Descriptor (Error "∞") rank mark copy)
272+ UF.set variable (Descriptor Error rank mark copy)
274− return $ state { _errors = Error.InfiniteType overallType : _errors state }
273+ return $ state { _errors = Error.InfiniteType errorType : _errors state }
275 else
274 else
276 return state
275 return state
277
276
@@ -412,7 +411,7 @@ adjustRankContent youngMark visitMark groupRank content =
412 -- THEORY: anything in the realVar would be outermostRank
411 -- THEORY: anything in the realVar would be outermostRank
413 foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
412 foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
414
413
415− Error _ ->
414+ Error ->
416 return groupRank
415 return groupRank
417
416
418
417
@@ -620,7 +619,7 @@ makeCopyHelp maxRank pools variable =
620 UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
619 UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
621 return copy
620 return copy
622
621
623− Error _ ->
622+ Error ->
624 return copy
623 return copy
625
624
626
625
@@ -685,7 +684,7 @@ restoreContent content =
685 do mapM_ (traverse restore) args
684 do mapM_ (traverse restore) args
686 restore var
685 restore var
687
686
688− Error _ ->
687+ Error ->
689 return ()
688 return ()
690
689
691
690
src/Type/Type.hs+190−51
@@ -1,7 +1,9 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Type
3module Type.Type
4+ ( Constraint(..)
5+ , exists
4− ( Variable
6+ , Variable
5 , FlatType(..)
7 , FlatType(..)
6 , Type(..)
8 , Type(..)
7 , Descriptor(Descriptor)
9 , Descriptor(Descriptor)
@@ -21,8 +23,8 @@ module Type.Type
21 , unnamedFlexSuper
23 , unnamedFlexSuper
22 , nameToFlex
24 , nameToFlex
23 , nameToRigid
25 , nameToRigid
24− , toSrcType
25 , toAnnotation
26 , toAnnotation
27+ , toErrorType
26 )
28 )
27 where
29 where
28
30
@@ -37,10 +39,45 @@ import qualified AST.Canonical as Can
37import qualified AST.Module.Name as ModuleName
39import qualified AST.Module.Name as ModuleName
38import qualified AST.Utils.Type as Type
40import qualified AST.Utils.Type as Type
39import qualified Elm.Name as N
41import qualified Elm.Name as N
42+import qualified Reporting.Annotation as A
43+import qualified Reporting.Error.Type as E
44+import qualified Reporting.Region as R
40import qualified Type.UnionFind as UF
45import qualified Type.UnionFind as UF
41
46
42
47
43
48
49+-- CONSTRAINTS
50+
51+
52+data Constraint
53+ = CTrue
54+ | CSaveTheEnvironment
55+ | CEqual R.Region E.Category Type (E.Expected Type)
56+ | CLocal R.Region N.Name (E.Expected Type)
57+ | CForeign R.Region N.Name Can.Annotation (E.Expected Type)
58+ | CPattern R.Region E.PCategory Type (E.PExpected Type)
59+ | CAnd [Constraint]
60+ | CBranch
61+ { _a :: Type
62+ , _b :: Type
63+ , _eq :: Constraint
64+ , _neq :: IO Constraint
65+ }
66+ | CLet
67+ { _rigidVars :: [Variable]
68+ , _flexVars :: [Variable]
69+ , _header :: Map.Map N.Name (A.Located Type)
70+ , _headerCon :: Constraint
71+ , _bodyCon :: Constraint
72+ }
73+
74+
75+exists :: [Variable] -> Constraint -> Constraint
76+exists flexVars constraint =
77+ CLet [] flexVars Map.empty constraint CTrue
78+
79+
80+
44-- TYPE PRIMITIVES
81-- TYPE PRIMITIVES
45
82
46
83
@@ -89,7 +126,7 @@ data Content
89 | RigidSuper SuperType N.Name
126 | RigidSuper SuperType N.Name
90 | Structure FlatType
127 | Structure FlatType
91 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
128 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
92− | Error N.Name
129+ | Error
93
130
94
131
95data SuperType
132data SuperType
@@ -300,117 +337,219 @@ toSuper name =
300
337
301
338
302
339
303−-- TO SOURCE TYPES
340+-- TO TYPE ANNOTATION
304
341
305
342
306−-- TODO: Attach resulting type to the descriptor so that you
307−-- never have to do extra work, particularly nice for aliased types
308toAnnotation :: Variable -> IO Can.Annotation
343toAnnotation :: Variable -> IO Can.Annotation
309toAnnotation variable =
344toAnnotation variable =
310 do userNames <- getVarNames variable Map.empty
345 do userNames <- getVarNames variable Map.empty
311 (tipe, NameState allNames _ _ _ _ _) <-
346 (tipe, NameState allNames _ _ _ _ _) <-
312− State.runStateT (variableToSrcType variable) (makeNameState userNames)
347+ State.runStateT (variableToCanType variable) (makeNameState userNames)
313− return $ Can.Forall (Map.map (\_ -> ()) allNames) tipe
348+ return $ Can.Forall (Map.map (const ()) allNames) tipe
349+
350+
351+variableToCanType :: Variable -> StateT NameState IO Can.Type
352+variableToCanType variable =
353+ do (Descriptor content _ _ _) <- liftIO $ UF.get variable
354+ case content of
355+ Structure term ->
356+ termToCanType term
357+
358+ FlexVar maybeName ->
359+ case maybeName of
360+ Just name ->
361+ return (Can.TVar name)
362+
363+ Nothing ->
364+ do name <- getFreshVarName
365+ liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
366+ return (Can.TVar name)
367+
368+ FlexSuper super maybeName ->
369+ case maybeName of
370+ Just name ->
371+ return (Can.TVar name)
372+
373+ Nothing ->
374+ do name <- getFreshSuperName super
375+ liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
376+ return (Can.TVar name)
377+
378+ RigidVar name ->
379+ return (Can.TVar name)
314
380
381+ RigidSuper _ name ->
382+ return (Can.TVar name)
315
383
384+ Alias home name args realVariable ->
385+ do canArgs <- traverse (traverse variableToCanType) args
386+ canType <- variableToCanType realVariable
387+ return (Can.TAlias home name canArgs (Can.Filled canType))
388+
389+ Error ->
390+ error "cannot handle Error types in variableToCanType"
391+
392+
393+termToCanType :: FlatType -> StateT NameState IO Can.Type
394+termToCanType term =
395+ case term of
396+ App1 home name args ->
397+ Can.TType home name <$> traverse variableToCanType args
398+
399+ Fun1 a b ->
400+ Can.TLambda
401+ <$> variableToCanType a
402+ <*> variableToCanType b
403+
404+ EmptyRecord1 ->
405+ return $ Can.TRecord Map.empty Nothing
406+
407+ Record1 fields extension ->
408+ do canFields <- traverse variableToCanType fields
409+ canExt <- Type.iteratedDealias <$> variableToCanType extension
410+ return $
411+ case canExt of
412+ Can.TRecord subFields subExt ->
413+ Can.TRecord (Map.union subFields canFields) subExt
414+
415+ Can.TVar _ ->
416+ Can.TRecord canFields (Just canExt)
417+
418+ _ ->
419+ error "Used toAnnotation on a type that is not well-formed"
420+
421+ Unit1 ->
422+ return Can.TUnit
423+
424+ Tuple1 a b maybeC ->
425+ Can.TTuple
426+ <$> variableToCanType a
427+ <*> variableToCanType b
428+ <*> traverse variableToCanType maybeC
429+
430+
431+
432+-- TO ERROR TYPE
433+
434+
316−toSrcType :: Variable -> IO Can.Type
435+toErrorType :: Variable -> IO E.Type
317−toSrcType variable =
436+toErrorType variable =
318 do userNames <- getVarNames variable Map.empty
437 do userNames <- getVarNames variable Map.empty
319− State.evalStateT (variableToSrcType variable) (makeNameState userNames)
438+ State.evalStateT (variableToErrorType variable) (makeNameState userNames)
320
439
321
440
322−variableToSrcType :: Variable -> StateT NameState IO Can.Type
441+variableToErrorType :: Variable -> StateT NameState IO E.Type
323−variableToSrcType variable =
442+variableToErrorType variable =
324 do descriptor <- liftIO $ UF.get variable
443 do descriptor <- liftIO $ UF.get variable
325 let mark = _mark descriptor
444 let mark = _mark descriptor
326 if mark == occursMark
445 if mark == occursMark
327 then
446 then
328− return (Can.TVar "∞")
447+ return E.Infinite
329
448
330 else
449 else
331 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
450 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
332− srcType <- contentToSrcType variable (_content descriptor)
451+ errType <- contentToErrorType variable (_content descriptor)
333 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
452 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
334− return srcType
453+ return errType
335
454
336
455
337−contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type
456+contentToErrorType :: Variable -> Content -> StateT NameState IO E.Type
338−contentToSrcType variable content =
457+contentToErrorType variable content =
339 case content of
458 case content of
340 Structure term ->
459 Structure term ->
341− termToSrcType term
460+ termToErrorType term
342
461
343 FlexVar maybeName ->
462 FlexVar maybeName ->
344 case maybeName of
463 case maybeName of
345 Just name ->
464 Just name ->
346− return (Can.TVar name)
465+ return (E.FlexVar name)
347
466
348 Nothing ->
467 Nothing ->
349 do name <- getFreshVarName
468 do name <- getFreshVarName
350 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
469 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
351− return (Can.TVar name)
470+ return (E.FlexVar name)
352
471
353 FlexSuper super maybeName ->
472 FlexSuper super maybeName ->
354 case maybeName of
473 case maybeName of
355 Just name ->
474 Just name ->
356− return (Can.TVar name)
475+ return (E.FlexSuper name)
357
476
358 Nothing ->
477 Nothing ->
359 do name <- getFreshSuperName super
478 do name <- getFreshSuperName super
360 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
479 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
361− return (Can.TVar name)
480+ return (E.FlexSuper name)
362
481
363 RigidVar name ->
482 RigidVar name ->
364− return (Can.TVar name)
483+ return (E.RigidVar name)
365
484
366 RigidSuper _ name ->
485 RigidSuper _ name ->
367− return (Can.TVar name)
486+ return (E.RigidSuper name)
368
487
369 Alias home name args realVariable ->
488 Alias home name args realVariable ->
370− do srcArgs <- traverse (traverse variableToSrcType) args
489+ do errArgs <- traverse (traverse variableToErrorType) args
371− srcType <- variableToSrcType realVariable
490+ errType <- variableToErrorType realVariable
372− return (Can.TAlias home name srcArgs (Can.Filled srcType))
491+ return (E.Alias home name errArgs errType)
373
492
374− Error name ->
493+ Error ->
375− return (Can.TVar name)
494+ return E.Error
376
495
377
496
378−termToSrcType :: FlatType -> StateT NameState IO Can.Type
497+termToErrorType :: FlatType -> StateT NameState IO E.Type
379−termToSrcType term =
498+termToErrorType term =
380 case term of
499 case term of
381 App1 home name args ->
500 App1 home name args ->
382− Can.TType home name <$> traverse variableToSrcType args
501+ E.Type home name <$> traverse variableToErrorType args
383
502
384 Fun1 a b ->
503 Fun1 a b ->
385− Can.TLambda
504+ do arg <- variableToErrorType a
386− <$> variableToSrcType a
505+ result <- variableToErrorType b
387− <*> variableToSrcType b
506+ return $
507+ case result of
508+ E.Lambda arg2 others ->
509+ E.Lambda arg (arg2:others)
510+
511+ _ ->
512+ E.Lambda arg [result]
388
513
389 EmptyRecord1 ->
514 EmptyRecord1 ->
390− return $ Can.TRecord Map.empty Nothing
515+ return $ E.Record Map.empty E.Closed
391
516
392 Record1 fields extension ->
517 Record1 fields extension ->
393− do srcFields <- traverse variableToSrcType fields
518+ do errFields <- traverse variableToErrorType fields
394− srcExt <- Type.iteratedDealias <$> variableToSrcType extension
519+ errExt <- iteratedErrorTypeDealias <$> variableToErrorType extension
395 return $
520 return $
396− case srcExt of
521+ case errExt of
397− Can.TRecord subFields subExt ->
522+ E.Record subFields subExt ->
398− Can.TRecord (Map.union subFields srcFields) subExt
523+ E.Record (Map.union subFields errFields) subExt
399
524
400− Can.TVar _ ->
525+ E.FlexVar ext ->
401− Can.TRecord srcFields (Just srcExt)
526+ E.Record errFields (E.FlexOpen ext)
527+
528+ E.RigidVar ext ->
529+ E.Record errFields (E.RigidOpen ext)
402
530
403 _ ->
531 _ ->
404− error "Used toSrcType on a type that is not well-formed"
532+ error "Used toErrorType on a type that is not well-formed"
405
533
406 Unit1 ->
534 Unit1 ->
407− return Can.TUnit
535+ return E.Unit
408
536
409 Tuple1 a b maybeC ->
537 Tuple1 a b maybeC ->
410− Can.TTuple
538+ E.Tuple
411− <$> variableToSrcType a
539+ <$> variableToErrorType a
412− <*> variableToSrcType b
540+ <*> variableToErrorType b
413− <*> traverse variableToSrcType maybeC
541+ <*> traverse variableToErrorType maybeC
542+
543+
544+iteratedErrorTypeDealias :: E.Type -> E.Type
545+iteratedErrorTypeDealias tipe =
546+ case tipe of
547+ E.Alias _ _ _ realType ->
548+ iteratedErrorTypeDealias realType
549+
550+ _ ->
551+ tipe
552+
414
553
415
554
416
555
@@ -516,7 +655,7 @@ getVarNames var takenNames =
516 else
655 else
517 do UF.set var (Descriptor content rank getVarNamesMark copy)
656 do UF.set var (Descriptor content rank getVarNamesMark copy)
518 case content of
657 case content of
519− Error _ ->
658+ Error ->
520 return takenNames
659 return takenNames
521
660
522 FlexVar maybeName ->
661 FlexVar maybeName ->
src/Type/Unify.hs+11−11
@@ -9,9 +9,9 @@ module Type.Unify
9
9
10import qualified Data.Map.Strict as Map
10import qualified Data.Map.Strict as Map
11
11
12−import qualified AST.Canonical as Can
13import qualified AST.Module.Name as ModuleName
12import qualified AST.Module.Name as ModuleName
14import qualified Elm.Name as N
13import qualified Elm.Name as N
14+import qualified Reporting.Error.Type as Error
15import qualified Type.Occurs as Occurs
15import qualified Type.Occurs as Occurs
16import Type.Type as Type
16import Type.Type as Type
17import qualified Type.UnionFind as UF
17import qualified Type.UnionFind as UF
@@ -23,7 +23,7 @@ import qualified Type.UnionFind as UF
23
23
24data Answer
24data Answer
25 = Ok [Variable]
25 = Ok [Variable]
26− | Err [Variable] Can.Type Can.Type
26+ | Err [Variable] Error.Type Error.Type
27
27
28
28
29unify :: Variable -> Variable -> IO Answer
29unify :: Variable -> Variable -> IO Answer
@@ -31,8 +31,8 @@ unify v1 v2 =
31 case guardedUnify v1 v2 of
31 case guardedUnify v1 v2 of
32 Unify k ->
32 Unify k ->
33 k [] onSuccess $ \vars () ->
33 k [] onSuccess $ \vars () ->
34− do t1 <- Type.toSrcType v1
34+ do t1 <- Type.toErrorType v1
35− t2 <- Type.toSrcType v2
35+ t2 <- Type.toErrorType v2
36 UF.union v1 v2 errorDescriptor
36 UF.union v1 v2 errorDescriptor
37 return (Err vars t1 t2)
37 return (Err vars t1 t2)
38
38
@@ -45,7 +45,7 @@ onSuccess vars () =
45{-# NOINLINE errorDescriptor #-}
45{-# NOINLINE errorDescriptor #-}
46errorDescriptor :: Descriptor
46errorDescriptor :: Descriptor
47errorDescriptor =
47errorDescriptor =
48− Descriptor (Error "?") noRank noMark Nothing
48+ Descriptor Error noRank noMark Nothing
49
49
50
50
51
51
@@ -212,7 +212,7 @@ actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor s
212 Structure flatType ->
212 Structure flatType ->
213 unifyStructure context flatType firstContent secondContent
213 unifyStructure context flatType firstContent secondContent
214
214
215− Error _ ->
215+ Error ->
216 -- If there was an error, just pretend it is okay. This lets us avoid
216 -- If there was an error, just pretend it is okay. This lets us avoid
217 -- "cascading" errors where one problem manifests as multiple message.
217 -- "cascading" errors where one problem manifests as multiple message.
218 return ()
218 return ()
@@ -225,7 +225,7 @@ actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor s
225unifyFlex :: Context -> Content -> Content -> Unify ()
225unifyFlex :: Context -> Content -> Content -> Unify ()
226unifyFlex context content otherContent =
226unifyFlex context content otherContent =
227 case otherContent of
227 case otherContent of
228− Error _ ->
228+ Error ->
229 return ()
229 return ()
230
230
231 -- TODO see if wildcarding makes a noticable perf difference
231 -- TODO see if wildcarding makes a noticable perf difference
@@ -288,7 +288,7 @@ unifyRigid context maybeSuper content otherContent =
288 Structure _ ->
288 Structure _ ->
289 mismatch
289 mismatch
290
290
291− Error _ ->
291+ Error ->
292 return ()
292 return ()
293
293
294
294
@@ -346,7 +346,7 @@ unifyFlexSuper context super content otherContent =
346 Alias _ _ _ realVar ->
346 Alias _ _ _ realVar ->
347 subUnify (_first context) realVar
347 subUnify (_first context) realVar
348
348
349− Error _ ->
349+ Error ->
350 return ()
350 return ()
351
351
352
352
@@ -488,7 +488,7 @@ unifyAlias context home name args realVar otherContent =
488 Structure _ ->
488 Structure _ ->
489 subUnify realVar (_second context)
489 subUnify realVar (_second context)
490
490
491− Error _ ->
491+ Error ->
492 return ()
492 return ()
493
493
494
494
@@ -592,7 +592,7 @@ unifyStructure context flatType content otherContent =
592 _ ->
592 _ ->
593 mismatch
593 mismatch
594
594
595− Error _ ->
595+ Error ->
596 return ()
596 return ()
597
597
598
598