344579b · elk · git.iko.soy

git.iko.soy/elk

Create special "error type" that has extra information

The idea is that type inference should produce AST.Canonical.Type if it succeeds. It can strip out rigid/flex info in that case. If type inference fails, it can produce an error type that includes info about infinite loops, errors, rigid variables, etc. I can then detect problems on that type more easily than doing it during unification. This change also introduces some improvements for operator type errors, specifically on the right side. E.g. if there is an (==) error, the whole expression should be underlined, not the right, because the error may be on either side.

commit344579bf2a05c3333493b55c86844dfe98044dca authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 7 Feb 2018, 14:28 (9 years ago) parentae89ac7

9 files changed+651−502

compare with master

unifiedsplit

src/Reporting/Error/Type.hs+390−209 src/Type/Constrain/Expression.hs+10−9 src/Type/Constrain/Module.hs+9−9 src/Type/Constrain/Pattern.hs+23−23 src/Type/Constraint.hs−171 src/Type/Occurs.hs+1−1 src/Type/Solve.hs+17−18 src/Type/Type.hs+190−51 src/Type/Unify.hs+11−11

src/Reporting/Error/Type.hs+390−209

@@ -2,7 +2,23 @@

22{-# LANGUAGE OverloadedStrings #-}

33module Reporting.Error.Type

44 ( Error(..)

5+ -- expectations

56 , 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

622 , toReport

723 )

824 where

@@ -11,17 +27,14 @@ module Reporting.Error.Type

1127import Prelude hiding (round)

1228import Data.Monoid ((<>))

1329

14−import qualified AST.Canonical as Can

1530import qualified AST.Module.Name as ModuleName

16−import qualified AST.Utils.Type as Type

1731import qualified Data.Index as Index

32+import qualified Data.Map as Map

1833import qualified Elm.Name as N

1934import qualified Reporting.Helpers as H

2035import qualified Reporting.Region as R

2136import qualified Reporting.Render.Code as Code

22−import qualified Reporting.Render.Type as Type

2337import qualified Reporting.Report as Report

24−import qualified Type.Constraint as C

2538

2639

2740

@@ -29,22 +42,159 @@ import qualified Type.Constraint as C

2942

3043

3144data Error

32− = Mismatch Origin (C.Expected Can.Type)

33− | BadPattern R.Region C.PCategory Can.Type (C.PExpected Can.Type)

34− | InfiniteType Can.Type

45+ = Mismatch Origin (Expected Type)

46+ | BadPattern R.Region PCategory Type (PExpected Type)

47+ | InfiniteType Type

48+

49+

50+

51+-- EXPRESSION EXPECTATIONS

3552

3653

3754data Origin

38− = BadExpr R.Region C.Category Can.Type

39− | BadLocal R.Region N.Name Can.Type

40− | BadForeign R.Region N.Name Can.Type

55+ = BadExpr R.Region Category Type

56+ | BadLocal R.Region N.Name 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

41191

42192

43193

44194-- TO REPORT

45195

46196

47−toReport :: Code.Source -> Type.Localizer -> Error -> Report.Report

197+toReport :: Code.Source -> Localizer -> Error -> Report.Report

48198toReport source localizer err =

49199 case err of

50200 Mismatch origin expected ->

@@ -71,27 +221,7 @@ toReport source localizer err =

71221

72222data Thing

73223 = Var N.Name

74− | Category C.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))

224+ | Category Category

95225

96226

97227toDescription :: Thing -> String -> String

@@ -102,38 +232,38 @@ toDescription thing thatThingIs =

102232

103233 Category category ->

104234 case category of

105− C.List -> thatThingIs <> " a list of type:"

106− C.Number -> thatThingIs <> " a number of type:"

107− C.Float -> thatThingIs <> " a float of type:"

108− C.String -> thatThingIs <> " a string of type:"

109− C.Char -> thatThingIs <> " a character of type:"

110− C.If -> "This `if` expression produces a value of type:"

111− C.Case -> "This `case` expression produces a value of type:"

112− C.Lambda -> thatThingIs <> " an anonymous function of type:"

113− C.Accessor field -> "This ." <> N.toString field <> " field access function has type of type:"

114− C.Access field -> "The value at ." <> N.toString field <> " has type of type:"

115− C.Record -> thatThingIs <> " a record of type:"

116− C.Tuple -> thatThingIs <> " a tuple of type:"

117− C.Unit -> thatThingIs <> " a unit value:"

118− C.Shader -> thatThingIs <> " a GLSL shader of type:"

119− C.Effects -> thatThingIs <> " a thing for CORE LIBRARIES ONLY."

120− C.CallResult maybeName ->

235+ List -> thatThingIs <> " a list of type:"

236+ Number -> thatThingIs <> " a number of type:"

237+ Float -> thatThingIs <> " a float of type:"

238+ String -> thatThingIs <> " a string of type:"

239+ Char -> thatThingIs <> " a character of type:"

240+ If -> "This `if` expression produces a value of type:"

241+ Case -> "This `case` expression produces a value of type:"

242+ LambdaExpr -> thatThingIs <> " an anonymous function of type:"

243+ Accessor field -> "This ." <> N.toString field <> " field access function has type:"

244+ Access field -> "The value at ." <> N.toString field <> " has type:"

245+ RecordExpr -> thatThingIs <> " a record of type:"

246+ TupleExpr -> thatThingIs <> " a tuple of type:"

247+ UnitExpr -> thatThingIs <> " a unit value:"

248+ Shader -> thatThingIs <> " a GLSL shader of type:"

249+ Effects -> thatThingIs <> " a thing for CORE LIBRARIES ONLY."

250+ CallResult maybeName ->

121251 case maybeName of

122− C.NoName -> thatThingIs <> ":"

123− C.FuncName name -> "This `" <> N.toString name <> "` call produces:"

124− C.CtorName name -> "This `" <> N.toString name <> "` call produces:"

125− C.OpName _ -> thatThingIs <> ":"

252+ NoName -> thatThingIs <> ":"

253+ FuncName name -> "This `" <> N.toString name <> "` call produces:"

254+ CtorName name -> "This `" <> N.toString name <> "` call produces:"

255+ OpName _ -> thatThingIs <> ":"

126256

127257

128258

129259-- TO MISMATCH REPORT

130260

131261

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

133263toMismatchReport source localizer exprRegion thing tipe expected =

134264 Report.Report "TYPE MISMATCH" exprRegion [] $

135265 case expected of

136− C.NoExpectation expectedType ->

266+ NoExpectation expectedType ->

137267 Report.toCodeSnippet source exprRegion Nothing

138268 (

139269 "This expression is being used in an unexpected way:"

@@ -150,31 +280,31 @@ toMismatchReport source localizer exprRegion thing tipe expected =

150280 )

151281 )

152282

153− C.FromAnnotation name arity subContext expectedType ->

283+ FromAnnotation name arity subContext expectedType ->

154284 Report.toCodeSnippet source exprRegion Nothing

155285 (

156286 H.reflow $

157287 case subContext of

158− C.TypedIfBranch index ->

288+ TypedIfBranch index ->

159289 "Something is off with the " <> H.ordinalize (Index.toHuman index) <> " branch of this `if` experssion:"

160290

161− C.TypedCaseBranch index ->

291+ TypedCaseBranch index ->

162292 "Something is off with the " <> H.ordinalize (Index.toHuman index) <> " branch of this `case` expression:"

163293

164− C.TypedBody ->

294+ TypedBody ->

165295 "Something is off with the body of the `" <> N.toString name <> "` definition:"

166296 ,

167297 typeComparison localizer tipe expectedType

168298 (

169299 toDescription thing $

170300 case subContext of

171− C.TypedIfBranch index ->

301+ TypedIfBranch index ->

172302 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"

173303

174− C.TypedCaseBranch index ->

304+ TypedCaseBranch index ->

175305 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"

176306

177− C.TypedBody ->

307+ TypedBody ->

178308 "The body is"

179309 ,

180310 "But the type annotation on `" <> N.toString name <> "` says it should be:"

@@ -185,9 +315,9 @@ toMismatchReport source localizer exprRegion thing tipe expected =

185315 )

186316 )

187317

188− C.FromContext region context expectedType ->

318+ FromContext region context expectedType ->

189319 case context of

190− C.ListEntry index ->

320+ ListEntry index ->

191321 if Index.toHuman index == 2 then

192322 error "TODO 1st vs 2nd list entry"

193323 else

@@ -213,7 +343,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

213343 )

214344 )

215345

216− C.Negate ->

346+ Negate ->

217347 Report.toCodeSnippet source region (Just exprRegion)

218348 (

219349 "I do not know how to negate this type of value:"

@@ -229,15 +359,19 @@ toMismatchReport source localizer exprRegion thing tipe expected =

229359 ]

230360 )

231361

232− C.OpLeft op ->

362+ OpLeft op ->

233363 Report.toCodeSnippet source region (Just exprRegion) $

234364 opLeftToDocs localizer thing op tipe expectedType

235365

236− C.OpRight op ->

237− Report.toCodeSnippet source region (Just exprRegion) $

238− opRightToDocs localizer thing op tipe expectedType

366+ OpRight op ->

367+ case opRightToDocs localizer thing op tipe expectedType of

368+ EmphBoth details ->

369+ Report.toCodeSnippet source region Nothing details

239370

240− C.IfCondition ->

371+ EmphRight details ->

372+ Report.toCodeSnippet source region (Just exprRegion) details

373+

374+ IfCondition ->

241375 Report.toCodeSnippet source region (Just exprRegion)

242376 (

243377 "This `if` condition does not evaluate to a boolean value, True or False."

@@ -252,7 +386,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

252386 ]

253387 )

254388

255− C.IfBranch index ->

389+ IfBranch index ->

256390 if Index.toHuman index == 2 then

257391 error "TODO 1st vs 2nd if branches"

258392 -- error "TODO if with no chaining"

@@ -279,7 +413,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

279413 )

280414 )

281415

282− C.CaseBranch index ->

416+ CaseBranch index ->

283417 if Index.toHuman index == 2 then

284418 error "TODO 1st vs 2nd case branches"

285419 else

@@ -305,20 +439,20 @@ toMismatchReport source localizer exprRegion thing tipe expected =

305439 )

306440 )

307441

308− C.CallArg maybeFuncName index ->

442+ CallArg maybeFuncName index ->

309443 let

310444 thisFunction =

311445 case maybeFuncName of

312− C.NoName ->

446+ NoName ->

313447 "this function"

314448

315− C.FuncName name ->

449+ FuncName name ->

316450 "`" <> N.toString name <> "`"

317451

318− C.CtorName name ->

452+ CtorName name ->

319453 "`" <> N.toString name <> "`"

320454

321− C.OpName op ->

455+ OpName op ->

322456 "(" <> N.toString op <> ")"

323457

324458 in

@@ -345,38 +479,38 @@ toMismatchReport source localizer exprRegion thing tipe expected =

345479 )

346480 )

347481

348− C.TooManyArgs maybeName numGivenArgs ->

349− case length (Type.delambda tipe) - 1 of

482+ TooManyArgs maybeName numGivenArgs ->

483+ case countArgs tipe of

350484 0 ->

351485 Report.toCodeSnippet source region (Just exprRegion)

352486 (

353487 H.reflow $

354488 case maybeName of

355− C.NoName ->

489+ NoName ->

356490 "You are giving " <> H.args numGivenArgs <> " to something that is not a function!"

357491

358− C.FuncName name ->

492+ FuncName name ->

359493 "`" <> N.toString name <> "` is not a function, but you are giving it " <> H.args numGivenArgs <> "!"

360494

361− C.CtorName name ->

495+ CtorName name ->

362496 "`" <> N.toString name <> "` is not a function, but you are giving it " <> H.args numGivenArgs <> "!"

363497

364− C.OpName op ->

498+ OpName op ->

365499 "(" <> N.toString op <> ") is not a function, but you are giving it " <> H.args numGivenArgs <> "!"

366500 ,

367501 typeComparison localizer tipe expectedType

368502 (

369503 case maybeName of

370− C.NoName ->

504+ NoName ->

371505 "It is a value of type:"

372506

373− C.FuncName name ->

507+ FuncName name ->

374508 "`" <> N.toString name <> "` is a value of type:"

375509

376− C.CtorName name ->

510+ CtorName name ->

377511 "`" <> N.toString name <> "` is a constructor of type:"

378512

379− C.OpName op ->

513+ OpName op ->

380514 "(" <> N.toString op <> ") is a value of type:"

381515 ,

382516 "But you are giving it " <> H.args numGivenArgs <> " as if its type was:"

@@ -390,16 +524,16 @@ toMismatchReport source localizer exprRegion thing tipe expected =

390524 let

391525 thisFunction =

392526 case maybeName of

393− C.NoName ->

527+ NoName ->

394528 "This function"

395529

396− C.FuncName name ->

530+ FuncName name ->

397531 "The `" <> N.toString name <> "` function"

398532

399− C.CtorName name ->

533+ CtorName name ->

400534 "The `" <> N.toString name <> "` constructor"

401535

402− C.OpName op ->

536+ OpName op ->

403537 "The (" <> N.toString op <> ") function"

404538 in

405539 Report.toCodeSnippet source region (Just exprRegion)

@@ -422,10 +556,10 @@ toMismatchReport source localizer exprRegion thing tipe expected =

422556 )

423557 )

424558

425− C.RecordAccess field ->

559+ RecordAccess field ->

426560 Report.toCodeSnippet source region (Just exprRegion) $

427− case Type.deepDealias tipe of

428− Can.TRecord _ _ ->

561+ case error "TODO figure out record things" tipe of

562+ Record _ _ ->

429563 (

430564 H.reflow $

431565 "This record does not have a `" <> N.toString field <> "` field:"

@@ -459,7 +593,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

459593 ]

460594 )

461595

462− Can.TLambda _ _ ->

596+ Lambda _ _ ->

463597 (

464598 H.reflow $

465599 "I cannot access field `" <> N.toString field <> "` of this " <> whatever <> ":"

@@ -484,9 +618,9 @@ toMismatchReport source localizer exprRegion thing tipe expected =

484618 ]

485619 )

486620

487− C.RecordUpdate ->

488− case Type.deepDealias tipe of

489− Can.TRecord _ _ ->

621+ RecordUpdate ->

622+ case error "TODO figure out record things" tipe of

623+ Record _ _ ->

490624 Report.toCodeSnippet source region Nothing

491625 (

492626 H.reflow $

@@ -507,15 +641,29 @@ toMismatchReport source localizer exprRegion thing tipe expected =

507641 ]

508642 )

509643

510− C.Destructure ->

644+ Destructure ->

511645 error "TODO Destructure"

512646

513647

514648

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+

515663-- OP LEFT

516664

517665

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)

519667opLeftToDocs localizer thing op tipe expectedType =

520668 case op of

521669 "+"

@@ -533,10 +681,10 @@ opLeftToDocs localizer thing op tipe expectedType =

533681 "//" -> badIDiv localizer "left" tipe

534682 "&&" -> badBool localizer "&&" "left" tipe

535683 "||" -> badBool localizer "||" "left" tipe

536− "<" -> badCompArg localizer thing "<" "left" tipe

537− ">" -> badCompArg localizer thing ">" "left" tipe

538− "<=" -> badCompArg localizer thing "<=" "left" tipe

539− ">=" -> badCompArg localizer thing ">=" "left" tipe

684+ "<" -> badCompLeft localizer thing "<" "left" tipe

685+ ">" -> badCompLeft localizer thing ">" "left" tipe

686+ "<=" -> badCompLeft localizer thing "<=" "left" tipe

687+ ">=" -> badCompLeft localizer thing ">=" "left" tipe

540688

541689 "<|" ->

542690 ( "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 =

548696 , error "TODO"

549697 {-

550698 case category of

551− C.Call ->

699+ Call ->

552700 "Maybe you gave " <> funcName <> " too many arguments already?"

553701

554702 _ ->

@@ -577,44 +725,53 @@ opLeftToDocs localizer thing op tipe expectedType =

577725-- OP RIGHT

578726

579727

580−opRightToDocs :: Type.Localizer -> Thing -> N.Name -> Can.Type -> Can.Type -> (H.Doc, H.Doc)

728+data RightDocs

729+ = EmphBoth (H.Doc, H.Doc)

730+ | EmphRight (H.Doc, H.Doc)

731+

732+

733+opRightToDocs :: Localizer -> Thing -> N.Name -> Type -> Type -> RightDocs

581734opRightToDocs localizer thing op tipe expectedType =

582735 case op of

583736 "+"

584737 | isInt tipe -> badCast op FloatInt

585738 | isFloat tipe -> badCast op IntFloat

586− | isString tipe -> badStringAdd

587− | isList tipe -> badListAdd localizer "right" tipe

588− | otherwise -> badMath localizer "Addition" "right" "+" tipe []

739+ | isString tipe -> EmphRight $ badStringAdd

740+ | isList tipe -> EmphRight $ badListAdd localizer "right" tipe

741+ | otherwise -> EmphRight $ badMath localizer "Addition" "right" "+" tipe []

589742

590743 "*"

591744 | isInt tipe -> badCast op FloatInt

592745 | isFloat tipe -> badCast op IntFloat

593− | isList tipe -> badListMul localizer "right" tipe

594− | otherwise -> badMath localizer "Multiplication" "right" "*" tipe []

746+ | isList tipe -> EmphRight $ badListMul localizer "right" tipe

747+ | otherwise -> EmphRight $ badMath localizer "Multiplication" "right" "*" tipe []

595748

596749 "-"

597750 | isInt tipe -> badCast op FloatInt

598751 | isFloat tipe -> badCast op IntFloat

599− | otherwise -> badMath localizer "Subtraction" "right" "-" tipe []

752+ | otherwise -> EmphRight $ badMath localizer "Subtraction" "right" "-" tipe []

600753

601754 "^"

602755 | isInt tipe -> badCast op FloatInt

603756 | isFloat tipe -> badCast op IntFloat

604− | otherwise -> badMath localizer "Exponentiation" "right" "^" tipe []

605−

606− "/" -> badFDiv localizer "right" tipe

607− "//" -> badIDiv localizer "right" tipe

608− "&&" -> badBool localizer "&&" "right" tipe

609− "||" -> badBool localizer "||" "right" tipe

610− "<" -> badCompRight localizer thing "<" tipe expectedType

611− ">" -> badCompRight localizer thing ">" tipe expectedType

612− "<=" -> badCompRight localizer thing "<=" tipe expectedType

613− ">=" -> badCompRight localizer thing ">=" tipe expectedType

757+ | otherwise -> EmphRight $ badMath localizer "Exponentiation" "right" "^" tipe []

758+

759+ "/" -> EmphRight $ badFDiv localizer "right" tipe

760+ "//" -> EmphRight $ badIDiv localizer "right" tipe

761+ "&&" -> EmphRight $ badBool localizer "&&" "right" tipe

762+ "||" -> EmphRight $ badBool localizer "||" "right" tipe

763+ "<" -> badCompRight localizer "<" tipe expectedType

764+ ">" -> badCompRight localizer ">" tipe expectedType

765+ "<=" -> badCompRight localizer "<=" tipe expectedType

766+ ">=" -> badCompRight localizer ">=" tipe expectedType

614767 "==" -> badEquality localizer "==" tipe expectedType

615768 "/=" -> badEquality localizer "/=" tipe expectedType

616769

770+ "::" ->

771+ error "TODO see if people want ++ instead?"

772+

617773 "<|" ->

774+ EmphRight

618775 (

619776 H.reflow $

620777 "I cannot pipe this " <> whatever <> " in as the final argument:"

@@ -633,7 +790,8 @@ opRightToDocs localizer thing op tipe expectedType =

633790

634791 "|>" ->

635792 case (tipe, expectedType) of

636− (Can.TLambda expectedArgType _, Can.TLambda argType _) ->

793+ (Lambda expectedArgType _, Lambda argType _) ->

794+ EmphRight

637795 (

638796 "I cannot pipe the argument through to this function:"

639797 ,

@@ -647,10 +805,10 @@ opRightToDocs localizer thing op tipe expectedType =

647805 Nothing ->

648806 "But (|>) is piping it a function that expects the next argument to be:"

649807

650− Just (C.FuncName name) ->

808+ Just (FuncName name) ->

651809 "But (|>) is piping it to `" <> N.toString name <> "` which expects the next argument to be:"

652810

653− Just (C.OpName op) ->

811+ Just (OpName op) ->

654812 "But (|>) is piping it to (" <> N.toString op <> ") which expects the next argument to be:"

655813 -}

656814 ,

@@ -661,6 +819,7 @@ opRightToDocs localizer thing op tipe expectedType =

661819 )

662820

663821 _ ->

822+ EmphRight

664823 (

665824 "The right side of (|>) needs to be a function so I can pipe arguments to it!"

666825 ,

@@ -681,6 +840,7 @@ opRightToDocs localizer thing op tipe expectedType =

681840 )

682841

683842 _ ->

843+ EmphRight

684844 (

685845 H.reflow $

686846 "The right argument of (" <> N.toString op <> ") is causing problems."

@@ -702,40 +862,40 @@ opRightToDocs localizer thing op tipe expectedType =

702862

703863

704864

705−isInt :: Can.Type -> Bool

865+isInt :: Type -> Bool

706866isInt tipe =

707867 case tipe of

708− Can.TType home name [] ->

868+ Type home name [] ->

709869 home == ModuleName.basics && name == N.int

710870

711871 _ ->

712872 False

713873

714874

715−isFloat :: Can.Type -> Bool

875+isFloat :: Type -> Bool

716876isFloat tipe =

717877 case tipe of

718− Can.TType home name [] ->

878+ Type home name [] ->

719879 home == ModuleName.basics && name == N.float

720880

721881 _ ->

722882 False

723883

724884

725−isString :: Can.Type -> Bool

885+isString :: Type -> Bool

726886isString tipe =

727887 case tipe of

728− Can.TType home name [] ->

888+ Type home name [] ->

729889 home == ModuleName.string && name == N.string

730890

731891 _ ->

732892 False

733893

734894

735−isList :: Can.Type -> Bool

895+isList :: Type -> Bool

736896isList tipe =

737897 case tipe of

738− Can.TType home name [_] ->

898+ Type home name [_] ->

739899 home == ModuleName.list && name == N.list

740900

741901 _ ->

@@ -754,25 +914,26 @@ whatever =

754914data ThisThenThat = FloatInt | IntFloat

755915

756916

757−badCast :: N.Name -> ThisThenThat -> (H.Doc, H.Doc)

917+badCast :: N.Name -> ThisThenThat -> RightDocs

758918badCast op thisThenThat =

759− (

760− H.text $

761− "I need both sides of (" <> N.toString op <> ") to be the exact same type. Both Int or both Float."

762− ,

763− let

764− anInt = ["an", H.dullyellow "Int"]

765− aFloat = ["a", H.dullyellow "Float"]

766− toFloat = H.green "toFloat"

767− round = H.green "round"

768− in

769− case thisThenThat of

770− FloatInt ->

771− badCastHelp aFloat anInt round toFloat

772−

773− IntFloat ->

774− badCastHelp anInt aFloat toFloat round

775− )

919+ EmphBoth

920+ (

921+ H.text $

922+ "I need both sides of (" <> N.toString op <> ") to be the exact same type. Both Int or both Float."

923+ ,

924+ let

925+ anInt = ["an", H.dullyellow "Int"]

926+ aFloat = ["a", H.dullyellow "Float"]

927+ toFloat = H.green "toFloat"

928+ round = H.green "round"

929+ in

930+ case thisThenThat of

931+ FloatInt ->

932+ badCastHelp aFloat anInt round toFloat

933+

934+ IntFloat ->

935+ badCastHelp anInt aFloat toFloat round

936+ )

776937

777938

778939badCastHelp :: [H.Doc] -> [H.Doc] -> H.Doc -> H.Doc -> H.Doc

@@ -808,7 +969,7 @@ badStringAdd =

808969 )

809970

810971

811−badListAdd :: Type.Localizer -> String -> Can.Type -> (H.Doc, H.Doc)

972+badListAdd :: Localizer -> String -> Type -> (H.Doc, H.Doc)

812973badListAdd localizer direction tipe =

813974 (

814975 "I cannot do addition with lists:"

@@ -827,7 +988,7 @@ badListAdd localizer direction tipe =

827988 )

828989

829990

830−badListMul :: Type.Localizer -> String -> Can.Type -> (H.Doc, H.Doc)

991+badListMul :: Localizer -> String -> Type -> (H.Doc, H.Doc)

831992badListMul localizer direction tipe =

832993 badMath localizer "Multiplication" direction "*" tipe

833994 [

@@ -839,7 +1000,7 @@ badListMul localizer direction tipe =

8391000 ]

8401001

8411002

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)

8431004badMath localizer operation direction op tipe otherHints =

8441005 (

8451006 H.reflow $

@@ -859,7 +1020,7 @@ badMath localizer operation direction op tipe otherHints =

8591020 )

8601021

8611022

862−badFDiv :: Type.Localizer -> H.Doc -> Can.Type -> (H.Doc, H.Doc)

1023+badFDiv :: Localizer -> H.Doc -> Type -> (H.Doc, H.Doc)

8631024badFDiv localizer direction tipe =

8641025 (

8651026 H.reflow $

@@ -892,7 +1053,7 @@ badFDiv localizer direction tipe =

8921053 )

8931054

8941055

895−badIDiv :: Type.Localizer -> H.Doc -> Can.Type -> (H.Doc, H.Doc)

1056+badIDiv :: Localizer -> H.Doc -> Type -> (H.Doc, H.Doc)

8961057badIDiv localizer direction tipe =

8971058 (

8981059 H.reflow $

@@ -931,7 +1092,7 @@ badIDiv localizer direction tipe =

9311092-- BAD BOOLS

9321093

9331094

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)

9351096badBool localizer op direction tipe =

9361097 (

9371098 H.reflow $

@@ -954,18 +1115,8 @@ badBool localizer op direction tipe =

9541115-- BAD COMPARISON

9551116

9561117

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)

968−badCompArg localizer thing op direction tipe =

1118+badCompLeft :: Localizer -> Thing -> String -> String -> Type -> (H.Doc, H.Doc)

1119+badCompLeft localizer thing op direction tipe =

9691120 (

9701121 H.reflow $

9711122 "I cannot do a comparison with this value:"

@@ -988,51 +1139,81 @@ badCompArg localizer thing op direction tipe =

9881139 )

9891140

9901141

991−badCompMix :: Type.Localizer -> String -> Can.Type -> Can.Type -> (H.Doc, H.Doc)

992−badCompMix localizer op tipe expectedType =

993− (

994− H.reflow $

995− "I need both sides of (" <> op <> ") to be the same type:"

996− ,

997− typeComparison localizer expectedType tipe

998− (

999− "The left side of is:"

1000− ,

1001− "But the right side is:"

1002− ,

1003− [ H.reflow $

1004− "I cannot compare different types though! Which side of (" <> op <> ") is the problem?"

1005− ]

1006− )

1007− )

1142+badCompRight :: Localizer -> String -> Type -> Type -> RightDocs

1143+badCompRight localizer op tipe expectedType =

1144+ EmphBoth

1145+ (

1146+ H.reflow $

1147+ "I need both sides of (" <> op <> ") to be the same type:"

1148+ ,

1149+ typeComparison localizer expectedType tipe

1150+ (

1151+ "The left side of is:"

1152+ ,

1153+ "But the right side is:"

1154+ ,

1155+ [ H.reflow $

1156+ "I cannot compare different types though! Which side of (" <> op <> ") is the problem?"

1157+ ]

1158+ )

1159+ )

10081160

10091161

10101162

10111163-- BAD EQUALITY

10121164

10131165

1014−badEquality :: Type.Localizer -> String -> Can.Type -> Can.Type -> (H.Doc, H.Doc)

1166+badEquality :: Localizer -> String -> Type -> Type -> RightDocs

10151167badEquality localizer op tipe expectedType =

1016− (

1017− H.reflow $

1018− "I need both sides of (" <> op <> ") to be the same type:"

1019− ,

1020− typeComparison localizer expectedType tipe

1021− (

1022− "The left side of is:"

1023− ,

1024− "But the right side is:"

1025− ,

1026− if isFloat tipe || isFloat expectedType then

1027− [ H.toSimpleNote $

1028− "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."

1030− ]

1031− else

1032− [ H.reflow $

1033− "Different types can never be equal though! Which side is messed up?"

1034− ]

1035−-- else

1036−-- error "TODO detect problems here instead?"

1037− )

1038− )

1168+ EmphBoth

1169+ (

1170+ H.reflow $

1171+ "I need both sides of (" <> op <> ") to be the same type:"

1172+ ,

1173+ typeComparison localizer expectedType tipe

1174+ (

1175+ "The left side of is:"

1176+ ,

1177+ "But the right side is:"

1178+ ,

1179+ if isFloat tipe || isFloat expectedType then

1180+ [ H.toSimpleNote $

1181+ "Equality on floats is not 100% reliable due to the design of IEEE 754. I\

1182+ \ recommend a check like (abs (x - y) < 0.0001) instead."

1183+ ]

1184+ else

1185+ [ H.reflow $

1186+ "Different types can never be equal though! Which side is messed up?"

1187+ ]

1188+-- else

1189+-- error "TODO detect problems here instead?"

1190+ )

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

1515import qualified Data.Index as Index

1616import qualified Elm.Name as N

1717import 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(..))

1820import qualified Reporting.Region as R

19−import Type.Constraint as C

2021import qualified Type.Constrain.Pattern as Pattern

2122import qualified Type.Instantiate as Instantiate

2223import Type.Type as Type hiding (Descriptor(..))

@@ -69,7 +70,7 @@ constrain rtv (A.At region expression) expected =

6970

7071 Can.Int _ ->

7172 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

7374

7475 Can.Float _ ->

7576 return $ CEqual region Float Type.float expected

@@ -81,7 +82,7 @@ constrain rtv (A.At region expression) expected =

8182 do numberVar <- mkFlexNumber

8283 let numberType = VarN numberVar

8384 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

8586 return $ exists [numberVar] $ CAnd [ numberCon, negateCon ]

8687

8788 Can.Binop op _ _ annotation leftExpr rightExpr ->

@@ -143,7 +144,7 @@ constrain rtv (A.At region expression) expected =

143144 constrainRecord rtv region fields expected

144145

145146 Can.Unit ->

146− return $ CEqual region Unit UnitN expected

147+ return $ CEqual region UnitExpr UnitN expected

147148

148149 Can.Tuple a b maybeC ->

149150 constrainTuple rtv region a b maybeC expected

@@ -173,7 +174,7 @@ constrainLambda rtv region args body expected =

173174 , _headerCon = CAnd (reverse revCons)

174175 , _bodyCon = bodyCon

175176 }

176− , CEqual region Lambda tipe expected

177+ , CEqual region LambdaExpr tipe expected

177178 ]

178179

179180

@@ -402,7 +403,7 @@ constrainRecord rtv region fields expected =

402403

403404 let getType (_, t, _) = t

404405 let recordType = RecordN (Map.map getType dict) EmptyRecordN

405− let recordCon = CEqual region Record recordType expected

406+ let recordCon = CEqual region RecordExpr recordType expected

406407

407408 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict

408409 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict

@@ -436,7 +437,7 @@ constrainUpdate rtv region expr fields expected =

436437

437438 let getType (_, t, _) = t

438439 let newRecordType = RecordN (Map.map getType newDict) sharedType

439− let newCon = CEqual region Record newRecordType expected

440+ let newCon = CEqual region RecordExpr newRecordType expected

440441

441442 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict

442443 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict

@@ -461,7 +462,7 @@ constrainTuple rtv region a b maybeC expected =

461462 case maybeC of

462463 Nothing ->

463464 do let tupleType = TupleN aType bType Nothing

464− let tupleCon = CEqual region Tuple tupleType expected

465+ let tupleCon = CEqual region TupleExpr tupleType expected

465466 return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]

466467

467468 Just c ->

@@ -471,7 +472,7 @@ constrainTuple rtv region a b maybeC expected =

471472 cCon <- constrain rtv c (NoExpectation cType)

472473

473474 let tupleType = TupleN aType bType (Just cType)

474− let tupleCon = CEqual region Tuple tupleType expected

475+ let tupleCon = CEqual region TupleExpr tupleType expected

475476

476477 return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]

477478

src/Type/Constrain/Module.hs+9−9

@@ -12,11 +12,11 @@ import qualified AST.Canonical as Can

1212import qualified AST.Module.Name as ModuleName

1313import qualified Elm.Name as N

1414import qualified Reporting.Annotation as A

15+import qualified Reporting.Error.Type as E

1516import qualified Reporting.Region as R

16−import Type.Constraint

1717import qualified Type.Constrain.Expression as Expr

1818import qualified Type.Instantiate as Instantiate

19−import Type.Type (Type(..), (==>), mkFlexVar, never)

19+import Type.Type (Type(..), Constraint(..), (==>), mkFlexVar, never)

2020

2121

2222

@@ -140,12 +140,12 @@ constrainEffects home r0 r1 r2 manager =

140140

141141 let effectCons =

142142 CAnd

143− [ CLocal r0 "init" (NoExpectation (task state0))

144− , CLocal r1 "onEffects" (NoExpectation onEffects)

145− , CLocal r2 "onSelfMsg" (NoExpectation onSelfMsg)

146− , CEqual r1 Effects state0 (NoExpectation state1)

147− , CEqual r2 Effects state0 (NoExpectation state2)

148− , CEqual r2 Effects self1 (NoExpectation self2)

143+ [ CLocal r0 "init" (E.NoExpectation (task state0))

144+ , CLocal r1 "onEffects" (E.NoExpectation onEffects)

145+ , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg)

146+ , CEqual r1 E.Effects state0 (E.NoExpectation state1)

147+ , CEqual r2 E.Effects state0 (E.NoExpectation state2)

148+ , CEqual r2 E.Effects self1 (E.NoExpectation self2)

149149 ]

150150

151151 CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>

@@ -181,7 +181,7 @@ checkMap name home tipe constraint =

181181 do a <- mkFlexVar

182182 b <- mkFlexVar

183183 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)

185185 return $ CLet [a,b] [] Map.empty mapCon constraint

186186

187187

src/Type/Constrain/Pattern.hs+23−23

@@ -16,8 +16,8 @@ import qualified AST.Module.Name as ModuleName

1616import qualified Data.Index as Index

1717import qualified Elm.Name as N

1818import qualified Reporting.Annotation as A

19+import qualified Reporting.Error.Type as E

1920import qualified Reporting.Region as R

20−import Type.Constraint

2121import qualified Type.Instantiate as Instantiate

2222import Type.Type as T

2323

@@ -40,7 +40,7 @@ data State =

4040type Header = Map.Map N.Name (A.Located Type)

4141

4242

43−add :: Can.Pattern -> PExpected Type -> State -> IO State

43+add :: Can.Pattern -> E.PExpected Type -> State -> IO State

4444add (A.At region pattern) expectation state =

4545 case pattern of

4646 Can.PAnything ->

@@ -55,7 +55,7 @@ add (A.At region pattern) expectation state =

5555

5656 Can.PUnit ->

5757 do let (State headers vars revCons) = state

58− let unitCon = CPattern region PUnit UnitN expectation

58+ let unitCon = CPattern region E.PUnit UnitN expectation

5959 return $ State headers vars (unitCon:revCons)

6060

6161 Can.PTuple a b maybeC ->

@@ -72,7 +72,7 @@ add (A.At region pattern) expectation state =

7272 (State headers vars revCons) <-

7373 foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)

7474

75− let listCon = CPattern region PList listType expectation

75+ let listCon = CPattern region E.PList listType expectation

7676 return $ State headers (entryVar:vars) (listCon:revCons)

7777

7878 Can.PCons headPattern tailPattern ->

@@ -80,14 +80,14 @@ add (A.At region pattern) expectation state =

8080 let entryType = VarN entryVar

8181 let listType = AppN ModuleName.list N.list [entryType]

8282

83− let headExpectation = PNoExpectation entryType

84− let tailExpectation = PFromContext region PTail listType

83+ let headExpectation = E.PNoExpectation entryType

84+ let tailExpectation = E.PFromContext region E.PTail listType

8585

8686 (State headers vars revCons) <-

8787 add headPattern headExpectation =<<

8888 add tailPattern tailExpectation state

8989

90− let listCon = CPattern region PList listType expectation

90+ let listCon = CPattern region E.PList listType expectation

9191 return $ State headers (entryVar:vars) (listCon : revCons)

9292

9393 Can.PRecord fields ->

@@ -99,7 +99,7 @@ add (A.At region pattern) expectation state =

9999 let recordType = RecordN fieldTypes extType

100100

101101 let (State headers vars revCons) = state

102− let recordCon = CPattern region PRecord recordType expectation

102+ let recordCon = CPattern region E.PRecord recordType expectation

103103 return $

104104 State

105105 { _headers = Map.union headers (Map.map (A.At region) fieldTypes)

@@ -109,17 +109,17 @@ add (A.At region pattern) expectation state =

109109

110110 Can.PInt _ ->

111111 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

113113 return $ State headers vars (intCon:revCons)

114114

115115 Can.PStr _ ->

116116 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

118118 return $ State headers vars (strCon:revCons)

119119

120120 Can.PChr _ ->

121121 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

123123 return $ State headers vars (chrCon:revCons)

124124

125125

@@ -133,7 +133,7 @@ emptyState =

133133 State Map.empty [] []

134134

135135

136−addToHeaders :: R.Region -> N.Name -> PExpected Type -> State -> State

136+addToHeaders :: R.Region -> N.Name -> E.PExpected Type -> State -> State

137137addToHeaders region name expectation (State headers vars revCons) =

138138 let

139139 tipe = getType expectation

@@ -142,11 +142,11 @@ addToHeaders region name expectation (State headers vars revCons) =

142142 State newHeaders vars revCons

143143

144144

145−getType :: PExpected Type -> Type

145+getType :: E.PExpected Type -> Type

146146getType expectation =

147147 case expectation of

148− PNoExpectation tipe -> tipe

149− PFromContext _ _ tipe -> tipe

148+ E.PNoExpectation tipe -> tipe

149+ E.PFromContext _ _ tipe -> tipe

150150

151151

152152

@@ -157,7 +157,7 @@ addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO St

157157addEntry listRegion tipe state (index, pattern) =

158158 let

159159 expectation =

160− PFromContext listRegion (PListEntry index) tipe

160+ E.PFromContext listRegion (E.PListEntry index) tipe

161161 in

162162 add pattern expectation state

163163

@@ -166,7 +166,7 @@ addEntry listRegion tipe state (index, pattern) =

166166-- CONSTRAIN TUPLE

167167

168168

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

170170addTuple region a b maybeC expectation state =

171171 do aVar <- mkFlexVar

172172 bVar <- mkFlexVar

@@ -179,7 +179,7 @@ addTuple region a b maybeC expectation state =

179179 simpleAdd b bType =<<

180180 simpleAdd a aType state

181181

182− let tupleCon = CPattern region PTuple (TupleN aType bType Nothing) expectation

182+ let tupleCon = CPattern region E.PTuple (TupleN aType bType Nothing) expectation

183183

184184 return $ State headers (aVar:bVar:vars) (tupleCon:revCons)

185185

@@ -192,21 +192,21 @@ addTuple region a b maybeC expectation state =

192192 simpleAdd b bType =<<

193193 simpleAdd a aType state

194194

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

196196

197197 return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)

198198

199199

200200simpleAdd :: Can.Pattern -> Type -> State -> IO State

201201simpleAdd pattern patternType state =

202− add pattern (PNoExpectation patternType) state

202+ add pattern (E.PNoExpectation patternType) state

203203

204204

205205

206206-- CONSTRAIN CONSTRUCTORS

207207

208208

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

210210addCtor region home typeName typeVarNames ctorName args expectation state =

211211 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames

212212 let typePairs = map (second VarN) varPairs

@@ -216,7 +216,7 @@ addCtor region home typeName typeVarNames ctorName args expectation state =

216216 foldM (addCtorArg region ctorName freeVarDict) state args

217217

218218 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

220220

221221 return $

222222 State

@@ -229,5 +229,5 @@ addCtor region home typeName typeVarNames ctorName args expectation state =

229229addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State

230230addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =

231231 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

233233 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 =

7676 Alias _ _ args _ ->

7777 foldrM (occursHelp (var:seen)) foundCycle (map snd args)

7878

79− Error _ ->

79+ Error ->

8080 return foundCycle

src/Type/Solve.hs+17−18

@@ -17,7 +17,6 @@ import qualified Elm.Name as N

1717import qualified Reporting.Annotation as A

1818import qualified Reporting.Error.Type as Error

1919import qualified Type.Occurs as Occurs

20−import Type.Constraint as Con

2120import Type.Type as Type

2221import qualified Type.Unify as Unify

2322import qualified Type.UnionFind as UF

@@ -92,7 +91,7 @@ solve env rank pools state constraint =

9291 return $ addError state $

9392 Error.Mismatch

9493 (Error.BadExpr region category actualType)

95− (Con.typeReplace expectation expectedType)

94+ (Error.typeReplace expectation expectedType)

9695

9796 CLocal region name expectation ->

9897 do actual <- makeCopy rank pools (env ! name)

@@ -108,7 +107,7 @@ solve env rank pools state constraint =

108107 return $ addError state $

109108 Error.Mismatch

110109 (Error.BadLocal region name actualType)

111− (Con.typeReplace expectation expectedType)

110+ (Error.typeReplace expectation expectedType)

112111

113112 CForeign region name (Can.Forall freeVars srcType) expectation ->

114113 do actual <- srcTypeToVariable rank pools freeVars srcType

@@ -124,7 +123,7 @@ solve env rank pools state constraint =

124123 return $ addError state $

125124 Error.Mismatch

126125 (Error.BadForeign region name actualType)

127− (Con.typeReplace expectation expectedType)

126+ (Error.typeReplace expectation expectedType)

128127

129128 CPattern region category tipe expectation ->

130129 do actual <- typeToVariable rank pools tipe

@@ -139,7 +138,7 @@ solve env rank pools state constraint =

139138 do introduce rank pools vars

140139 return $ addError state $

141140 Error.BadPattern region category actualType

142− (Con.ptypeReplace expectation expectedType)

141+ (Error.ptypeReplace expectation expectedType)

143142

144143 CAnd constraints ->

145144 foldM (solve env rank pools) state constraints

@@ -225,28 +224,28 @@ isGeneric var =

225224-- EXPECTATIONS TO VARIABLE

226225

227226

228−expectedToVariable :: Int -> Pools -> Expected Type -> IO Variable

227+expectedToVariable :: Int -> Pools -> Error.Expected Type -> IO Variable

229228expectedToVariable rank pools expectation =

230229 typeToVariable rank pools $

231230 case expectation of

232− NoExpectation tipe ->

231+ Error.NoExpectation tipe ->

233232 tipe

234233

235− FromContext _ _ tipe ->

234+ Error.FromContext _ _ tipe ->

236235 tipe

237236

238− FromAnnotation _ _ _ tipe ->

237+ Error.FromAnnotation _ _ _ tipe ->

239238 tipe

240239

241240

242−patternExpectationToVariable :: Int -> Pools -> PExpected Type -> IO Variable

241+patternExpectationToVariable :: Int -> Pools -> Error.PExpected Type -> IO Variable

243242patternExpectationToVariable rank pools expectation =

244243 typeToVariable rank pools $

245244 case expectation of

246− PNoExpectation tipe ->

245+ Error.PNoExpectation tipe ->

247246 tipe

248247

249− PFromContext _ _ tipe ->

248+ Error.PFromContext _ _ tipe ->

250249 tipe

251250

252251

@@ -268,10 +267,10 @@ occurs state (_name, A.At _region variable) =

268267 do hasOccurred <- Occurs.occurs variable

269268 if hasOccurred

270269 then

271− do overallType <- Type.toSrcType variable

270+ do errorType <- Type.toErrorType variable

272271 (Descriptor _ rank mark copy) <- UF.get variable

273− UF.set variable (Descriptor (Error "∞") rank mark copy)

274− return $ state { _errors = Error.InfiniteType overallType : _errors state }

272+ UF.set variable (Descriptor Error rank mark copy)

273+ return $ state { _errors = Error.InfiniteType errorType : _errors state }

275274 else

276275 return state

277276

@@ -412,7 +411,7 @@ adjustRankContent youngMark visitMark groupRank content =

412411 -- THEORY: anything in the realVar would be outermostRank

413412 foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args

414413

415− Error _ ->

414+ Error ->

416415 return groupRank

417416

418417

@@ -620,7 +619,7 @@ makeCopyHelp maxRank pools variable =

620619 UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)

621620 return copy

622621

623− Error _ ->

622+ Error ->

624623 return copy

625624

626625

@@ -685,7 +684,7 @@ restoreContent content =

685684 do mapM_ (traverse restore) args

686685 restore var

687686

688− Error _ ->

687+ Error ->

689688 return ()

690689

691690

src/Type/Type.hs+190−51

@@ -1,7 +1,9 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Type.Type

4− ( Variable

4+ ( Constraint(..)

5+ , exists

6+ , Variable

57 , FlatType(..)

68 , Type(..)

79 , Descriptor(Descriptor)

@@ -21,8 +23,8 @@ module Type.Type

2123 , unnamedFlexSuper

2224 , nameToFlex

2325 , nameToRigid

24− , toSrcType

2526 , toAnnotation

27+ , toErrorType

2628 )

2729 where

2830

@@ -37,10 +39,45 @@ import qualified AST.Canonical as Can

3739import qualified AST.Module.Name as ModuleName

3840import qualified AST.Utils.Type as Type

3941import 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

4045import qualified Type.UnionFind as UF

4146

4247

4348

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+

4481-- TYPE PRIMITIVES

4582

4683

@@ -89,7 +126,7 @@ data Content

89126 | RigidSuper SuperType N.Name

90127 | Structure FlatType

91128 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable

92− | Error N.Name

129+ | Error

93130

94131

95132data SuperType

@@ -300,117 +337,219 @@ toSuper name =

300337

301338

302339

303−-- TO SOURCE TYPES

340+-- TO TYPE ANNOTATION

304341

305342

306−-- TODO: Attach resulting type to the descriptor so that you

307−-- never have to do extra work, particularly nice for aliased types

308343toAnnotation :: Variable -> IO Can.Annotation

309344toAnnotation variable =

310345 do userNames <- getVarNames variable Map.empty

311346 (tipe, NameState allNames _ _ _ _ _) <-

312− State.runStateT (variableToSrcType variable) (makeNameState userNames)

313− return $ Can.Forall (Map.map (\_ -> ()) allNames) tipe

347+ State.runStateT (variableToCanType variable) (makeNameState userNames)

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)

314380

381+ RigidSuper _ name ->

382+ return (Can.TVar name)

315383

316−toSrcType :: Variable -> IO Can.Type

317−toSrcType variable =

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+

435+toErrorType :: Variable -> IO E.Type

436+toErrorType variable =

318437 do userNames <- getVarNames variable Map.empty

319− State.evalStateT (variableToSrcType variable) (makeNameState userNames)

438+ State.evalStateT (variableToErrorType variable) (makeNameState userNames)

320439

321440

322−variableToSrcType :: Variable -> StateT NameState IO Can.Type

323−variableToSrcType variable =

441+variableToErrorType :: Variable -> StateT NameState IO E.Type

442+variableToErrorType variable =

324443 do descriptor <- liftIO $ UF.get variable

325444 let mark = _mark descriptor

326445 if mark == occursMark

327446 then

328− return (Can.TVar "∞")

447+ return E.Infinite

329448

330449 else

331450 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })

332− srcType <- contentToSrcType variable (_content descriptor)

451+ errType <- contentToErrorType variable (_content descriptor)

333452 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })

334− return srcType

453+ return errType

335454

336455

337−contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type

338−contentToSrcType variable content =

456+contentToErrorType :: Variable -> Content -> StateT NameState IO E.Type

457+contentToErrorType variable content =

339458 case content of

340459 Structure term ->

341− termToSrcType term

460+ termToErrorType term

342461

343462 FlexVar maybeName ->

344463 case maybeName of

345464 Just name ->

346− return (Can.TVar name)

465+ return (E.FlexVar name)

347466

348467 Nothing ->

349468 do name <- getFreshVarName

350469 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })

351− return (Can.TVar name)

470+ return (E.FlexVar name)

352471

353472 FlexSuper super maybeName ->

354473 case maybeName of

355474 Just name ->

356− return (Can.TVar name)

475+ return (E.FlexSuper name)

357476

358477 Nothing ->

359478 do name <- getFreshSuperName super

360479 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })

361− return (Can.TVar name)

480+ return (E.FlexSuper name)

362481

363482 RigidVar name ->

364− return (Can.TVar name)

483+ return (E.RigidVar name)

365484

366485 RigidSuper _ name ->

367− return (Can.TVar name)

486+ return (E.RigidSuper name)

368487

369488 Alias home name args realVariable ->

370− do srcArgs <- traverse (traverse variableToSrcType) args

371− srcType <- variableToSrcType realVariable

372− return (Can.TAlias home name srcArgs (Can.Filled srcType))

489+ do errArgs <- traverse (traverse variableToErrorType) args

490+ errType <- variableToErrorType realVariable

491+ return (E.Alias home name errArgs errType)

373492

374− Error name ->

375− return (Can.TVar name)

493+ Error ->

494+ return E.Error

376495

377496

378−termToSrcType :: FlatType -> StateT NameState IO Can.Type

379−termToSrcType term =

497+termToErrorType :: FlatType -> StateT NameState IO E.Type

498+termToErrorType term =

380499 case term of

381500 App1 home name args ->

382− Can.TType home name <$> traverse variableToSrcType args

501+ E.Type home name <$> traverse variableToErrorType args

383502

384503 Fun1 a b ->

385− Can.TLambda

386− <$> variableToSrcType a

387− <*> variableToSrcType b

504+ do arg <- variableToErrorType a

505+ result <- variableToErrorType 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]

388513

389514 EmptyRecord1 ->

390− return $ Can.TRecord Map.empty Nothing

515+ return $ E.Record Map.empty E.Closed

391516

392517 Record1 fields extension ->

393− do srcFields <- traverse variableToSrcType fields

394− srcExt <- Type.iteratedDealias <$> variableToSrcType extension

518+ do errFields <- traverse variableToErrorType fields

519+ errExt <- iteratedErrorTypeDealias <$> variableToErrorType extension

395520 return $

396− case srcExt of

397− Can.TRecord subFields subExt ->

398− Can.TRecord (Map.union subFields srcFields) subExt

521+ case errExt of

522+ E.Record subFields subExt ->

523+ E.Record (Map.union subFields errFields) subExt

399524

400− Can.TVar _ ->

401− Can.TRecord srcFields (Just srcExt)

525+ E.FlexVar ext ->

526+ E.Record errFields (E.FlexOpen ext)

527+

528+ E.RigidVar ext ->

529+ E.Record errFields (E.RigidOpen ext)

402530

403531 _ ->

404− error "Used toSrcType on a type that is not well-formed"

532+ error "Used toErrorType on a type that is not well-formed"

405533

406534 Unit1 ->

407− return Can.TUnit

535+ return E.Unit

408536

409537 Tuple1 a b maybeC ->

410− Can.TTuple

411− <$> variableToSrcType a

412− <*> variableToSrcType b

413− <*> traverse variableToSrcType maybeC

538+ E.Tuple

539+ <$> variableToErrorType a

540+ <*> variableToErrorType b

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+

414553

415554

416555

@@ -516,7 +655,7 @@ getVarNames var takenNames =

516655 else

517656 do UF.set var (Descriptor content rank getVarNamesMark copy)

518657 case content of

519− Error _ ->

658+ Error ->

520659 return takenNames

521660

522661 FlexVar maybeName ->

src/Type/Unify.hs+11−11

@@ -9,9 +9,9 @@ module Type.Unify

1010import qualified Data.Map.Strict as Map

1111

12−import qualified AST.Canonical as Can

1312import qualified AST.Module.Name as ModuleName

1413import qualified Elm.Name as N

14+import qualified Reporting.Error.Type as Error

1515import qualified Type.Occurs as Occurs

1616import Type.Type as Type

1717import qualified Type.UnionFind as UF

@@ -23,7 +23,7 @@ import qualified Type.UnionFind as UF

2323

2424data Answer

2525 = Ok [Variable]

26− | Err [Variable] Can.Type Can.Type

26+ | Err [Variable] Error.Type Error.Type

2727

2828

2929unify :: Variable -> Variable -> IO Answer

@@ -31,8 +31,8 @@ unify v1 v2 =

3131 case guardedUnify v1 v2 of

3232 Unify k ->

3333 k [] onSuccess $ \vars () ->

34− do t1 <- Type.toSrcType v1

35− t2 <- Type.toSrcType v2

34+ do t1 <- Type.toErrorType v1

35+ t2 <- Type.toErrorType v2

3636 UF.union v1 v2 errorDescriptor

3737 return (Err vars t1 t2)

3838

@@ -45,7 +45,7 @@ onSuccess vars () =

4545{-# NOINLINE errorDescriptor #-}

4646errorDescriptor :: Descriptor

4747errorDescriptor =

48− Descriptor (Error "?") noRank noMark Nothing

48+ Descriptor Error noRank noMark Nothing

4949

5050

5151

@@ -212,7 +212,7 @@ actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor s

212212 Structure flatType ->

213213 unifyStructure context flatType firstContent secondContent

214214

215− Error _ ->

215+ Error ->

216216 -- If there was an error, just pretend it is okay. This lets us avoid

217217 -- "cascading" errors where one problem manifests as multiple message.

218218 return ()

@@ -225,7 +225,7 @@ actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor s

225225unifyFlex :: Context -> Content -> Content -> Unify ()

226226unifyFlex context content otherContent =

227227 case otherContent of

228− Error _ ->

228+ Error ->

229229 return ()

230230

231231 -- TODO see if wildcarding makes a noticable perf difference

@@ -288,7 +288,7 @@ unifyRigid context maybeSuper content otherContent =

288288 Structure _ ->

289289 mismatch

290290

291− Error _ ->

291+ Error ->

292292 return ()

293293

294294

@@ -346,7 +346,7 @@ unifyFlexSuper context super content otherContent =

346346 Alias _ _ _ realVar ->

347347 subUnify (_first context) realVar

348348

349− Error _ ->

349+ Error ->

350350 return ()

351351

352352

@@ -488,7 +488,7 @@ unifyAlias context home name args realVar otherContent =

488488 Structure _ ->

489489 subUnify realVar (_second context)

490490

491− Error _ ->

491+ Error ->

492492 return ()

493493

494494

@@ -592,7 +592,7 @@ unifyStructure context flatType content otherContent =

592592 _ ->

593593 mismatch

594594

595− Error _ ->

595+ Error ->

596596 return ()

597597

598598