dd2feec · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Create Type.Error module and simplify Error type a bit

dd2feecEvan Czaplicki9 years ago

elm-compiler.cabal+1

compare with master

unifiedsplit

@@ -134,6 +134,7 @@ Library

134 Type.Constrain.Expression,

135 Type.Constrain.Module,

136 Type.Constrain.Pattern,

137+ Type.Error,

137 Type.Instantiate,

138 Type.Instantiate,

138 Type.Occurs,

139 Type.Occurs,

139 Type.Solve,

140 Type.Solve,

src/Reporting/Error/Type.hs+91−143

@@ -3,7 +3,6 @@

3module Reporting.Error.Type

4 ( Error(..)

5 -- expectations

6− , Origin(..)

7 , Expected(..)

6 , Expected(..)

8 , Context(..)

7 , Context(..)

9 , SubContext(..)

8 , SubContext(..)

@@ -14,10 +13,6 @@ module Reporting.Error.Type

14 , PCategory(..)

13 , PCategory(..)

15 , typeReplace

14 , typeReplace

16 , ptypeReplace

15 , ptypeReplace

17− -- error types

18− , Type(..)

19− , Extension(..)

20− , Localizer

21 -- make reports

16 -- make reports

22 , toReport

17 , toReport

23 )

18 )

@@ -29,12 +24,12 @@ import Data.Monoid ((<>))

30import qualified AST.Module.Name as ModuleName

25import qualified AST.Module.Name as ModuleName

31import qualified Data.Index as Index

26import qualified Data.Index as Index

32−import qualified Data.Map as Map

33import qualified Elm.Name as N

27import qualified Elm.Name as N

34import qualified Reporting.Helpers as H

28import qualified Reporting.Helpers as H

35import qualified Reporting.Region as R

29import qualified Reporting.Region as R

36import qualified Reporting.Render.Code as Code

30import qualified Reporting.Render.Code as Code

37import qualified Reporting.Report as Report

31import qualified Reporting.Report as Report

32+import qualified Type.Error as T

@@ -42,21 +37,15 @@ import qualified Reporting.Report as Report

44data Error

39data Error

45− = Mismatch Origin (Expected Type)

40+ = Mismatch R.Region Category T.Type (Expected T.Type)

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

41+ | BadPattern R.Region PCategory T.Type (PExpected T.Type)

47− | InfiniteType Type

42+ | InfiniteType T.Type

51-- EXPRESSION EXPECTATIONS

46-- EXPRESSION EXPECTATIONS

54−data Origin

55− = BadExpr R.Region Category Type

56− | BadLocal R.Region N.Name Type

57− | BadForeign R.Region N.Name Type

58−

59−

60data Expected tipe

49data Expected tipe

61 = NoExpectation tipe

50 = NoExpectation tipe

62 | FromContext R.Region Context tipe

51 | FromContext R.Region Context tipe

@@ -100,14 +89,16 @@ data Category

100 | If

89 | If

101 | Case

90 | Case

102 | CallResult MaybeName

91 | CallResult MaybeName

103− | LambdaExpr

92+ | Lambda

104 | Accessor N.Name

93 | Accessor N.Name

105 | Access N.Name

94 | Access N.Name

106− | RecordExpr

95+ | Record

107− | TupleExpr

96+ | Tuple

108− | UnitExpr

97+ | Unit

109 | Shader

98 | Shader

110 | Effects

99 | Effects

100+ | Local N.Name

101+ | Foreign N.Name

111

102

112

103

113

104

@@ -166,47 +157,14 @@ ptypeReplace expectation tipe =

166

157

167

158

168

159

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

191−

192−

193−

194-- TO REPORT

160-- TO REPORT

195

161

196

162

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

163+toReport :: Code.Source -> T.Localizer -> Error -> Report.Report

198toReport source localizer err =

164toReport source localizer err =

199 case err of

165 case err of

200− Mismatch origin expected ->

166+ Mismatch region category actualType expected ->

201− case origin of

202− BadForeign region name tipe ->

203− toMismatchReport source localizer region (Var name) tipe expected

204−

205− BadLocal region name tipe ->

206− toMismatchReport source localizer region (Var name) tipe expected

167+ toMismatchReport source localizer region category actualType expected

207−

208− BadExpr region category tipe ->

209− toMismatchReport source localizer region (Category category) tipe expected

210

168

211 BadPattern region category tipe expected ->

169 BadPattern region category tipe expected ->

212 error "TODO" region category tipe expected

170 error "TODO" region category tipe expected

@@ -219,48 +177,40 @@ toReport source localizer err =

219-- HELPERS

177-- HELPERS

220

178

221

179

222−data Thing

223− = Var N.Name

224− | Category Category

225−

226−

227−toDescription :: Thing -> String -> String

180+toDescription :: Category -> String -> String

228−toDescription thing thatThingIs =

181+toDescription category thatThingIs =

229− case thing of

182+ case category of

230− Var name ->

183+ Local name -> "This `" <> N.toString name <> "` value has type:"

231− "This `" <> N.toString name <> "` value has type:"

184+ Foreign name -> "This `" <> N.toString name <> "` value has type:"

232−

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

233− Category category ->

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

234− case category of

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

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

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

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

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

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

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

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

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

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

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

193+ 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:"

194+ Lambda -> 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:"

195+ Record -> thatThingIs <> " a record of type:"

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

196+ Tuple -> thatThingIs <> " a tuple of type:"

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

197+ Unit -> thatThingIs <> " a unit value:"

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

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

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

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

250− CallResult maybeName ->

200+ CallResult maybeName ->

251− case maybeName of

201+ case maybeName of

252− NoName -> thatThingIs <> ":"

202+ NoName -> thatThingIs <> ":"

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

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

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

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

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

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

256

206

257

207

258

208

259-- TO MISMATCH REPORT

209-- TO MISMATCH REPORT

260

210

261

211

262−toMismatchReport :: Code.Source -> Localizer -> R.Region -> Thing -> Type -> Expected Type -> Report.Report

212+toMismatchReport :: Code.Source -> T.Localizer -> R.Region -> Category -> T.Type -> Expected T.Type -> Report.Report

263−toMismatchReport source localizer exprRegion thing tipe expected =

213+toMismatchReport source localizer exprRegion category tipe expected =

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

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

265 case expected of

215 case expected of

266 NoExpectation expectedType ->

216 NoExpectation expectedType ->

@@ -270,7 +220,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

270 ,

220 ,

271 typeComparison localizer tipe expectedType

221 typeComparison localizer tipe expectedType

272 (

222 (

273− toDescription thing "It is"

223+ toDescription category "It is"

274 ,

224 ,

275 "But you are trying to use it as:"

225 "But you are trying to use it as:"

276 ,

226 ,

@@ -296,7 +246,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

296 ,

246 ,

297 typeComparison localizer tipe expectedType

247 typeComparison localizer tipe expectedType

298 (

248 (

299− toDescription thing $

249+ toDescription category $

300 case subContext of

250 case subContext of

301 TypedIfBranch index ->

251 TypedIfBranch index ->

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

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

@@ -328,7 +278,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

328 ,

278 ,

329 typeComparison localizer tipe expectedType

279 typeComparison localizer tipe expectedType

330 (

280 (

331− toDescription thing $

281+ toDescription category $

332 "The " <> H.ordinalize (Index.toHuman index) <> " element is"

282 "The " <> H.ordinalize (Index.toHuman index) <> " element is"

333 ,

283 ,

334 "But all the previous elements in the list are:"

284 "But all the previous elements in the list are:"

@@ -349,7 +299,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

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

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

350 ,

300 ,

351 H.stack

301 H.stack

352− [ H.reflow $ toDescription thing "It is"

302+ [ H.reflow $ toDescription category "It is"

353 , indentType localizer tipe

303 , indentType localizer tipe

354 , H.fillSep

304 , H.fillSep

355 ["But","I","only","now","how","to","negate"

305 ["But","I","only","now","how","to","negate"

@@ -361,10 +311,10 @@ toMismatchReport source localizer exprRegion thing tipe expected =

361

311

362 OpLeft op ->

312 OpLeft op ->

363 Report.toCodeSnippet source region (Just exprRegion) $

313 Report.toCodeSnippet source region (Just exprRegion) $

364− opLeftToDocs localizer thing op tipe expectedType

314+ opLeftToDocs localizer category op tipe expectedType

365

315

366 OpRight op ->

316 OpRight op ->

367− case opRightToDocs localizer thing op tipe expectedType of

317+ case opRightToDocs localizer category op tipe expectedType of

368 EmphBoth details ->

318 EmphBoth details ->

369 Report.toCodeSnippet source region Nothing details

319 Report.toCodeSnippet source region Nothing details

370

320

@@ -377,7 +327,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

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

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

378 ,

328 ,

379 H.stack

329 H.stack

380− [ H.reflow $ toDescription thing "It is"

330+ [ H.reflow $ toDescription category "It is"

381 , indentType localizer tipe

331 , indentType localizer tipe

382 , H.fillSep ["But","I","need","this","`if`","condition","to","be","a",H.dullyellow "Bool","value."]

332 , H.fillSep ["But","I","need","this","`if`","condition","to","be","a",H.dullyellow "Bool","value."]

383 , H.toSimpleHint $

333 , H.toSimpleHint $

@@ -398,7 +348,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

398 ,

348 ,

399 typeComparison localizer tipe expectedType

349 typeComparison localizer tipe expectedType

400 (

350 (

401− toDescription thing $

351+ toDescription category $

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

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

403 ,

353 ,

404 "But all the previous branches result in:"

354 "But all the previous branches result in:"

@@ -424,7 +374,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

424 ,

374 ,

425 typeComparison localizer tipe expectedType

375 typeComparison localizer tipe expectedType

426 (

376 (

427− toDescription thing $

377+ toDescription category $

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

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

429 ,

379 ,

430 "But all the previous branches result in:"

380 "But all the previous branches result in:"

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

463 ,

413 ,

464 typeComparison localizer tipe expectedType

414 typeComparison localizer tipe expectedType

465 (

415 (

466− toDescription thing "This argument is"

416+ toDescription category "This argument is"

467 ,

417 ,

468 "But " <> thisFunction <> " needs the " <> H.ordinalize (Index.toHuman index)

418 "But " <> thisFunction <> " needs the " <> H.ordinalize (Index.toHuman index)

469 <> " argument to be:"

419 <> " argument to be:"

@@ -559,7 +509,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

559 RecordAccess field ->

509 RecordAccess field ->

560 Report.toCodeSnippet source region (Just exprRegion) $

510 Report.toCodeSnippet source region (Just exprRegion) $

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

511 case error "TODO figure out record things" tipe of

562− Record _ _ ->

512+ T.Record _ _ ->

563 (

513 (

564 H.reflow $

514 H.reflow $

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

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

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

593 ]

543 ]

594 )

544 )

595

545

596− Lambda _ _ ->

546+ T.Lambda _ _ _ ->

597 (

547 (

598 H.reflow $

548 H.reflow $

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

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

@@ -620,7 +570,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

620

570

621 RecordUpdate ->

571 RecordUpdate ->

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

572 case error "TODO figure out record things" tipe of

623− Record _ _ ->

573+ T.Record _ _ ->

624 Report.toCodeSnippet source region Nothing

574 Report.toCodeSnippet source region Nothing

625 (

575 (

626 H.reflow $

576 H.reflow $

@@ -649,11 +599,11 @@ toMismatchReport source localizer exprRegion thing tipe expected =

649-- COUNT ARGS

599-- COUNT ARGS

650

600

651

601

652−countArgs :: Type -> Int

602+countArgs :: T.Type -> Int

653countArgs tipe =

603countArgs tipe =

654 case tipe of

604 case tipe of

655− Lambda _ stuff ->

605+ T.Lambda _ _ stuff ->

656− length stuff

606+ 1 + length stuff

657

607

658 _ ->

608 _ ->

659 0

609 0

@@ -663,8 +613,8 @@ countArgs tipe =

663-- OP LEFT

613-- OP LEFT

664

614

665

615

666−opLeftToDocs :: Localizer -> Thing -> N.Name -> Type -> Type -> (H.Doc, H.Doc)

616+opLeftToDocs :: T.Localizer -> Category -> N.Name -> T.Type -> T.Type -> (H.Doc, H.Doc)

667−opLeftToDocs localizer thing op tipe expectedType =

617+opLeftToDocs localizer category op tipe expectedType =

668 case op of

618 case op of

669 "+"

619 "+"

670 | isString tipe -> badStringAdd

620 | isString tipe -> badStringAdd

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

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

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

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

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

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

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

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

634+ "<" -> badCompLeft localizer category "<" "left" tipe

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

635+ ">" -> badCompLeft localizer category ">" "left" tipe

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

636+ "<=" -> badCompLeft localizer category "<=" "left" tipe

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

637+ ">=" -> badCompLeft localizer category ">=" "left" tipe

688

638

689 "<|" ->

639 "<|" ->

690 ( "The left side of (<|) needs to be a function so I can pipe arguments to it!"

640 ( "The left side of (<|) needs to be a function so I can pipe arguments to it!"

@@ -712,7 +662,7 @@ opLeftToDocs localizer thing op tipe expectedType =

712 ,

662 ,

713 typeComparison localizer tipe expectedType

663 typeComparison localizer tipe expectedType

714 (

664 (

715− toDescription thing "The left argument is"

665+ toDescription category "The left argument is"

716 ,

666 ,

717 "But (" <> N.toString op <> ") needs the left argument to be:"

667 "But (" <> N.toString op <> ") needs the left argument to be:"

718 ,

668 ,

@@ -730,8 +680,8 @@ data RightDocs

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

680 | EmphRight (H.Doc, H.Doc)

731

681

732

682

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

683+opRightToDocs :: T.Localizer -> Category -> N.Name -> T.Type -> T.Type -> RightDocs

734−opRightToDocs localizer thing op tipe expectedType =

684+opRightToDocs localizer category op tipe expectedType =

735 case op of

685 case op of

736 "+"

686 "+"

737 | isInt tipe -> badCast op FloatInt

687 | isInt tipe -> badCast op FloatInt

@@ -778,7 +728,7 @@ opRightToDocs localizer thing op tipe expectedType =

778 ,

728 ,

779 typeComparison localizer tipe expectedType

729 typeComparison localizer tipe expectedType

780 (

730 (

781− toDescription thing "You are providing"

731+ toDescription category "You are providing"

782 ,

732 ,

783 "But (<|) is piping it a function that expects:"

733 "But (<|) is piping it a function that expects:"

784 ,

734 ,

@@ -790,9 +740,10 @@ opRightToDocs localizer thing op tipe expectedType =

790

740

791 "|>" ->

741 "|>" ->

792 case (tipe, expectedType) of

742 case (tipe, expectedType) of

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

743+ (T.Lambda expectedArgType _ _, T.Lambda argType _ _) ->

794 EmphRight

744 EmphRight

795 (

745 (

746+ -- TODO try to say the function name instead of "this function"

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

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

797 ,

748 ,

798 typeComparison localizer argType expectedArgType

749 typeComparison localizer argType expectedArgType

@@ -847,7 +798,7 @@ opRightToDocs localizer thing op tipe expectedType =

847 ,

798 ,

848 typeComparison localizer tipe expectedType

799 typeComparison localizer tipe expectedType

849 (

800 (

850− toDescription thing "The right argument is"

801+ toDescription category "The right argument is"

851 ,

802 ,

852 "But (" <> N.toString op <> ") needs the right argument to be:"

803 "But (" <> N.toString op <> ") needs the right argument to be:"

853 ,

804 ,

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

862

813

863

814

864

815

865−isInt :: Type -> Bool

816+isInt :: T.Type -> Bool

866isInt tipe =

817isInt tipe =

867 case tipe of

818 case tipe of

868− Type home name [] ->

819+ T.Type home name [] ->

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

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

870

821

871 _ ->

822 _ ->

872 False

823 False

873

824

874

825

875−isFloat :: Type -> Bool

826+isFloat :: T.Type -> Bool

876isFloat tipe =

827isFloat tipe =

877 case tipe of

828 case tipe of

878− Type home name [] ->

829+ T.Type home name [] ->

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

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

880

831

881 _ ->

832 _ ->

882 False

833 False

883

834

884

835

885−isString :: Type -> Bool

836+isString :: T.Type -> Bool

886isString tipe =

837isString tipe =

887 case tipe of

838 case tipe of

888− Type home name [] ->

839+ T.Type home name [] ->

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

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

890

841

891 _ ->

842 _ ->

892 False

843 False

893

844

894

845

895−isList :: Type -> Bool

846+isList :: T.Type -> Bool

896isList tipe =

847isList tipe =

897 case tipe of

848 case tipe of

898− Type home name [_] ->

849+ T.Type home name [_] ->

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

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

900

851

901 _ ->

852 _ ->

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

969 )

920 )

970

921

971

922

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

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

973badListAdd localizer direction tipe =

924badListAdd localizer direction tipe =

974 (

925 (

975 "I cannot do addition with lists:"

926 "I cannot do addition with lists:"

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

988 )

939 )

989

940

990

941

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

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

992badListMul localizer direction tipe =

943badListMul localizer direction tipe =

993 badMath localizer "Multiplication" direction "*" tipe

944 badMath localizer "Multiplication" direction "*" tipe

994 [

945 [

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

1000 ]

951 ]

1001

952

1002

953

1003−badMath :: Localizer -> String -> String -> String -> Type -> [H.Doc] -> (H.Doc, H.Doc)

954+badMath :: T.Localizer -> String -> String -> String -> T.Type -> [H.Doc] -> (H.Doc, H.Doc)

1004badMath localizer operation direction op tipe otherHints =

955badMath localizer operation direction op tipe otherHints =

1005 (

956 (

1006 H.reflow $

957 H.reflow $

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

1020 )

971 )

1021

972

1022

973

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

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

1024badFDiv localizer direction tipe =

975badFDiv localizer direction tipe =

1025 (

976 (

1026 H.reflow $

977 H.reflow $

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

1053 )

1004 )

1054

1005

1055

1006

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

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

1057badIDiv localizer direction tipe =

1008badIDiv localizer direction tipe =

1058 (

1009 (

1059 H.reflow $

1010 H.reflow $

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

1092-- BAD BOOLS

1043-- BAD BOOLS

1093

1044

1094

1045

1095−badBool :: Localizer -> H.Doc -> H.Doc -> Type -> (H.Doc, H.Doc)

1046+badBool :: T.Localizer -> H.Doc -> H.Doc -> T.Type -> (H.Doc, H.Doc)

1096badBool localizer op direction tipe =

1047badBool localizer op direction tipe =

1097 (

1048 (

1098 H.reflow $

1049 H.reflow $

@@ -1115,14 +1066,14 @@ badBool localizer op direction tipe =

1115-- BAD COMPARISON

1066-- BAD COMPARISON

1116

1067

1117

1068

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

1069+badCompLeft :: T.Localizer -> Category -> String -> String -> T.Type -> (H.Doc, H.Doc)

1119−badCompLeft localizer thing op direction tipe =

1070+badCompLeft localizer category op direction tipe =

1120 (

1071 (

1121 H.reflow $

1072 H.reflow $

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

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

1123 ,

1074 ,

1124 H.stack

1075 H.stack

1125− [ H.reflow $ toDescription thing $

1076+ [ H.reflow $ toDescription category $

1126 "The " <> direction <> " side of (" <> op <> ") is"

1077 "The " <> direction <> " side of (" <> op <> ") is"

1127 , indentType localizer tipe

1078 , indentType localizer tipe

1128 , H.fillSep

1079 , H.fillSep

@@ -1139,7 +1090,7 @@ badCompLeft localizer thing op direction tipe =

1139 )

1090 )

1140

1091

1141

1092

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

1093+badCompRight :: T.Localizer -> String -> T.Type -> T.Type -> RightDocs

1143badCompRight localizer op tipe expectedType =

1094badCompRight localizer op tipe expectedType =

1144 EmphBoth

1095 EmphBoth

1145 (

1096 (

@@ -1163,7 +1114,7 @@ badCompRight localizer op tipe expectedType =

1163-- BAD EQUALITY

1114-- BAD EQUALITY

1164

1115

1165

1116

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

1117+badEquality :: T.Localizer -> String -> T.Type -> T.Type -> RightDocs

1167badEquality localizer op tipe expectedType =

1118badEquality localizer op tipe expectedType =

1168 EmphBoth

1119 EmphBoth

1169 (

1120 (

@@ -1195,10 +1146,7 @@ badEquality localizer op tipe expectedType =

1195-- DIFF TYPES

1146-- DIFF TYPES

1196

1147

1197

1148

1198−type Localizer = Map.Map N.Name ()

1199−

1200−

1201−typeComparison :: Localizer -> Type -> Type -> ( String, String, [H.Doc] ) -> H.Doc

1149+typeComparison :: T.Localizer -> T.Type -> T.Type -> ( String, String, [H.Doc] ) -> H.Doc

1202typeComparison localizer actual expected ( iAmSeeing, insteadOf, soHereAreSomeThoughts ) =

1150typeComparison localizer actual expected ( iAmSeeing, insteadOf, soHereAreSomeThoughts ) =

1203 let

1151 let

1204 (actualDoc, expectedDoc) =

1152 (actualDoc, expectedDoc) =

@@ -1213,7 +1161,7 @@ typeComparison localizer actual expected ( iAmSeeing, insteadOf, soHereAreSomeTh

1213 ++ soHereAreSomeThoughts

1161 ++ soHereAreSomeThoughts

1214

1162

1215

1163

1216−indentType :: Localizer -> Type -> H.Doc

1164+indentType :: T.Localizer -> T.Type -> H.Doc

1217indentType localizer tipe =

1165indentType localizer tipe =

1218 H.indent 4 (H.dullyellow (error "TODO Type.toDoc" localizer tipe))

1166 H.indent 4 (H.dullyellow (error "TODO Type.toDoc" localizer tipe))

1219

1167

src/Type/Constrain/Expression.hs+6−6

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

144 constrainRecord rtv region fields expected

145

146 Can.Unit ->

147− return $ CEqual region UnitExpr UnitN expected

147+ return $ CEqual region Unit UnitN expected

148

149 Can.Tuple a b maybeC ->

150 constrainTuple rtv region a b maybeC expected

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

174 , _headerCon = CAnd (reverse revCons)

175 , _bodyCon = bodyCon

176 }

177− , CEqual region LambdaExpr tipe expected

177+ , CEqual region Lambda tipe expected

178 ]

179

180

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

403

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

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

406− let recordCon = CEqual region RecordExpr recordType expected

406+ let recordCon = CEqual region Record recordType expected

407

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

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

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

437

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

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

440− let newCon = CEqual region RecordExpr newRecordType expected

440+ let newCon = CEqual region Record newRecordType expected

441

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

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

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

462 case maybeC of

463 Nothing ->

464 do let tupleType = TupleN aType bType Nothing

465− let tupleCon = CEqual region TupleExpr tupleType expected

465+ let tupleCon = CEqual region Tuple tupleType expected

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

467

468 Just c ->

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

472 cCon <- constrain rtv c (NoExpectation cType)

473

474 let tupleType = TupleN aType bType (Just cType)

475− let tupleCon = CEqual region TupleExpr tupleType expected

475+ let tupleCon = CEqual region Tuple tupleType expected

476

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

478

src/Type/Error.hsnew file+157

@@ -0,0 +1,157 @@

1+module Type.Error

2+ ( Type(..)

3+ , Extension(..)

4+ , iteratedDealias

5+ , Localizer

6+ )

7+ where

10+import qualified Data.Map as Map

11+

12+import qualified AST.Module.Name as ModuleName

13+import qualified Elm.Name as N

14+

15+

16+

17+-- ERROR TYPES

18+

19+

20+data Type

21+ = Lambda Type Type [Type]

22+ | Infinite

23+ | Error

24+ | FlexVar N.Name

25+ | FlexSuper N.Name

26+ | RigidVar N.Name

27+ | RigidSuper N.Name

28+ | Type ModuleName.Canonical N.Name [Type]

29+ | Record (Map.Map N.Name Type) Extension

30+ | Unit

31+ | Tuple Type Type (Maybe Type)

32+ | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type

33+

34+

35+data Extension

36+ = Closed

37+ | FlexOpen N.Name

38+ | RigidOpen N.Name

39+

40+

41+iteratedDealias :: Type -> Type

42+iteratedDealias tipe =

43+ case tipe of

44+ Alias _ _ _ realType ->

45+ iteratedDealias realType

46+

47+ _ ->

48+ tipe

49+

50+

51+

52+-- LOCALIZE

53+

54+

55+type Localizer = Map.Map N.Name ()

56+

57+

58+

59+

60+{-- DIFF

61+

62+

63+data Diff

64+ = TooFewArgs

65+ |

66+

67+

68+

69+

70+-- DETECT MISSING ARGS

71+

72+

73+detectMissingArgs :: Type -> Type -> Maybe (Type, [Type])

74+detectMissingArgs actual expected =

75+ detectMissingArgsHelp (reverseArgs actual) (reverseArgs expected)

76+

77+

78+detectMissingArgsHelp :: [Type] -> [Type] -> Maybe (Type, [Type])

79+detectMissingArgsHelp actuals expecteds =

80+ case (actuals, expecteds) of

81+ (x:xs, y:ys) -> if isMatchy x y then detectMissingArgsHelp xs ys else Nothing

82+ (x:xs, []) -> Just (x, xs)

83+ ([], []) -> Nothing

84+ ([], _:_) -> Nothing

85+

86+

87+reverseArgs :: Type -> [Type]

88+reverseArgs tipe =

89+ case tipe of

90+ Lambda a b cs -> reverse (a:b:cs)

91+ Infinite -> [tipe]

92+ Error -> [tipe]

93+ FlexVar _ -> [tipe]

94+ FlexSuper _ -> [tipe]

95+ RigidVar _ -> [tipe]

96+ RigidSuper _ -> [tipe]

97+ Type _ _ _ -> [tipe]

98+ Record _ _ -> [tipe]

99+ Unit -> [tipe]

100+ Tuple _ _ _ -> [tipe]

101+ Alias _ _ _ t -> reverseArgs t

102+

103+

104+isMatchy :: Type -> Type -> Bool

105+isMatchy t1 t2 =

106+ case (t1, t2) of

107+ (Lambda a b cs, Lambda x y zs) ->

108+ isMatchy a x && isMatchy b y && length cs == length zs && and (zipWith isMatchy cs zs)

109+

110+ (Infinite, Infinite) ->

111+ True

112+

113+ (Error, Error) ->

114+ True

115+

116+ (FlexVar _, _) ->

117+ True

118+

119+ (_, FlexVar _) ->

120+ True

121+

122+ (FlexSuper x, FlexSuper y) ->

123+ x == y

124+

125+ (RigidVar x, RigidVar y) ->

126+ x == y

127+

128+ (RigidSuper x, RigidSuper y) ->

129+ x == y

130+

131+ (Type home1 name1 args1, Type home2 name2 args2) ->

132+ home1 == home2 && name1 == name2 && and (zipWith isMatchy args1 args2)

133+

134+ (Record fields1 ext1, Record fields2 ext2) ->

135+ isMatchRecord

136+ (Map.size (Map.difference fields1 fields2))

137+ (Map.intersectionWith isMatchy fields1 fields2)

138+ (Map.size (Map.difference fields2 fields1))

139+

140+ (Unit, Unit) ->

141+ True

142+

143+ (Tuple a b Nothing, Tuple x y Nothing) ->

144+ isMatchy a x && isMatchy b y

145+

146+ (Tuple a b (Just c), Tuple x y (Just z)) ->

147+ isMatchy a x && isMatchy b y && isMatchy c z

148+

149+ (Alias _ _ _ alias1, tipe2) ->

150+ isMatchy alias1 tipe2

151+

152+ (tipe1, Alias _ _ _ alias2) ->

153+ isMatchy tipe1 alias2

154+

155+ (_, _) ->

156+ False

157+-}

src/Type/Solve.hs+6−9

@@ -89,9 +89,8 @@ solve env rank pools state constraint =

89 Unify.Err vars actualType expectedType ->

90 do introduce rank pools vars

91 return $ addError state $

92− Error.Mismatch

93− (Error.BadExpr region category actualType)

92+ Error.Mismatch region category actualType $

94− (Error.typeReplace expectation expectedType)

93+ Error.typeReplace expectation expectedType

96 CLocal region name expectation ->

95 CLocal region name expectation ->

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

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

@@ -105,9 +104,8 @@ solve env rank pools state constraint =

105 Unify.Err vars actualType expectedType ->

104 Unify.Err vars actualType expectedType ->

106 do introduce rank pools vars

105 do introduce rank pools vars

107 return $ addError state $

106 return $ addError state $

108− Error.Mismatch

109− (Error.BadLocal region name actualType)

107+ Error.Mismatch region (Error.Local name) actualType $

110− (Error.typeReplace expectation expectedType)

108+ Error.typeReplace expectation expectedType

111

109

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

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

113 do actual <- srcTypeToVariable rank pools freeVars srcType

111 do actual <- srcTypeToVariable rank pools freeVars srcType

@@ -121,9 +119,8 @@ solve env rank pools state constraint =

121 Unify.Err vars actualType expectedType ->

119 Unify.Err vars actualType expectedType ->

122 do introduce rank pools vars

120 do introduce rank pools vars

123 return $ addError state $

121 return $ addError state $

124− Error.Mismatch

125− (Error.BadForeign region name actualType)

122+ Error.Mismatch region (Error.Foreign name) actualType $

126− (Error.typeReplace expectation expectedType)

123+ Error.typeReplace expectation expectedType

127

124

128 CPattern region category tipe expectation ->

125 CPattern region category tipe expectation ->

129 do actual <- typeToVariable rank pools tipe

126 do actual <- typeToVariable rank pools tipe

src/Type/Type.hs+28−38

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

42import qualified Reporting.Annotation as A

43import qualified Reporting.Error.Type as E

44import qualified Reporting.Region as R

45+import qualified Type.Error as ET

45import qualified Type.UnionFind as UF

46import qualified Type.UnionFind as UF

@@ -432,19 +433,19 @@ termToCanType term =

432-- TO ERROR TYPE

433-- TO ERROR TYPE

433

434

435

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

436+toErrorType :: Variable -> IO ET.Type

436toErrorType variable =

437toErrorType variable =

437 do userNames <- getVarNames variable Map.empty

438 do userNames <- getVarNames variable Map.empty

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

439 State.evalStateT (variableToErrorType variable) (makeNameState userNames)

439

440

441

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

442+variableToErrorType :: Variable -> StateT NameState IO ET.Type

442variableToErrorType variable =

443variableToErrorType variable =

443 do descriptor <- liftIO $ UF.get variable

444 do descriptor <- liftIO $ UF.get variable

444 let mark = _mark descriptor

445 let mark = _mark descriptor

445 if mark == occursMark

446 if mark == occursMark

446 then

447 then

447− return E.Infinite

448+ return ET.Infinite

448

449

449 else

450 else

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

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

@@ -453,7 +454,7 @@ variableToErrorType variable =

453 return errType

454 return errType

454

455

456

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

457+contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type

457contentToErrorType variable content =

458contentToErrorType variable content =

458 case content of

459 case content of

459 Structure term ->

460 Structure term ->

@@ -462,96 +463,85 @@ contentToErrorType variable content =

462 FlexVar maybeName ->

463 FlexVar maybeName ->

463 case maybeName of

464 case maybeName of

464 Just name ->

465 Just name ->

465− return (E.FlexVar name)

466+ return (ET.FlexVar name)

466

467

467 Nothing ->

468 Nothing ->

468 do name <- getFreshVarName

469 do name <- getFreshVarName

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

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

470− return (E.FlexVar name)

471+ return (ET.FlexVar name)

471

472

472 FlexSuper super maybeName ->

473 FlexSuper super maybeName ->

473 case maybeName of

474 case maybeName of

474 Just name ->

475 Just name ->

475− return (E.FlexSuper name)

476+ return (ET.FlexSuper name)

476

477

477 Nothing ->

478 Nothing ->

478 do name <- getFreshSuperName super

479 do name <- getFreshSuperName super

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

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

480− return (E.FlexSuper name)

481+ return (ET.FlexSuper name)

481

482

482 RigidVar name ->

483 RigidVar name ->

483− return (E.RigidVar name)

484+ return (ET.RigidVar name)

484

485

485 RigidSuper _ name ->

486 RigidSuper _ name ->

486− return (E.RigidSuper name)

487+ return (ET.RigidSuper name)

487

488

488 Alias home name args realVariable ->

489 Alias home name args realVariable ->

489 do errArgs <- traverse (traverse variableToErrorType) args

490 do errArgs <- traverse (traverse variableToErrorType) args

490 errType <- variableToErrorType realVariable

491 errType <- variableToErrorType realVariable

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

492+ return (ET.Alias home name errArgs errType)

492

493

493 Error ->

494 Error ->

494− return E.Error

495+ return ET.Error

495

496

497

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

498+termToErrorType :: FlatType -> StateT NameState IO ET.Type

498termToErrorType term =

499termToErrorType term =

499 case term of

500 case term of

500 App1 home name args ->

501 App1 home name args ->

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

502+ ET.Type home name <$> traverse variableToErrorType args

502

503

503 Fun1 a b ->

504 Fun1 a b ->

504 do arg <- variableToErrorType a

505 do arg <- variableToErrorType a

505 result <- variableToErrorType b

506 result <- variableToErrorType b

506 return $

507 return $

507 case result of

508 case result of

508− E.Lambda arg2 others ->

509+ ET.Lambda arg1 arg2 others ->

509− E.Lambda arg (arg2:others)

510+ ET.Lambda arg arg1 (arg2:others)

510

511

511 _ ->

512 _ ->

512− E.Lambda arg [result]

513+ ET.Lambda arg result []

513

514

514 EmptyRecord1 ->

515 EmptyRecord1 ->

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

516+ return $ ET.Record Map.empty ET.Closed

516

517

517 Record1 fields extension ->

518 Record1 fields extension ->

518 do errFields <- traverse variableToErrorType fields

519 do errFields <- traverse variableToErrorType fields

519− errExt <- iteratedErrorTypeDealias <$> variableToErrorType extension

520+ errExt <- ET.iteratedDealias <$> variableToErrorType extension

520 return $

521 return $

521 case errExt of

522 case errExt of

522− E.Record subFields subExt ->

523+ ET.Record subFields subExt ->

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

524+ ET.Record (Map.union subFields errFields) subExt

524

525

525− E.FlexVar ext ->

526+ ET.FlexVar ext ->

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

527+ ET.Record errFields (ET.FlexOpen ext)

527

528

528− E.RigidVar ext ->

529+ ET.RigidVar ext ->

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

530+ ET.Record errFields (ET.RigidOpen ext)

530

531

531 _ ->

532 _ ->

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

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

533

534

534 Unit1 ->

535 Unit1 ->

535− return E.Unit

536+ return ET.Unit

536

537

537 Tuple1 a b maybeC ->

538 Tuple1 a b maybeC ->

538− E.Tuple

539+ ET.Tuple

539 <$> variableToErrorType a

540 <$> variableToErrorType a

540 <*> variableToErrorType b

541 <*> variableToErrorType b

541 <*> traverse variableToErrorType maybeC

542 <*> traverse variableToErrorType maybeC

542

543

544

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−

553−

554−

555

545

556-- MANAGE FRESH VARIABLE NAMES

546-- MANAGE FRESH VARIABLE NAMES

557

547

src/Type/Unify.hs+1−1

@@ -11,7 +11,7 @@ import qualified Data.Map.Strict as Map

12import qualified AST.Module.Name as ModuleName

13import qualified Elm.Name as N

14−import qualified Reporting.Error.Type as Error

14+import qualified Type.Error as Error

15import qualified Type.Occurs as Occurs

16import Type.Type as Type

17import qualified Type.UnionFind as UF