e02350a · elk · git.iko.soy

git.iko.soy/elk

Show plausible errors on record mismatch / give field typo suggestions

commite02350aea770f2aedecf49b9728d6c160bffeb14 authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 25 Apr 2018, 01:03 (9 years ago) parenta639058

2 files changed+434−604

compare with master

unifiedsplit

compiler/src/Reporting/Error/Type.hs+105−145 compiler/src/Type/Error.hs+329−459

compiler/src/Reporting/Error/Type.hs+105−145

@@ -191,7 +191,7 @@ toPatternReport source localizer patternRegion category tipe expected =

191191 ( "This pattern is being used in an unexpected way:"

192192 , patternTypeComparison localizer tipe expectedType

193193 (addPatternCategory "It is" category)

194− (singular "But it needs to match")

194+ "But it needs to match:"

195195 []

196196 )

197197

@@ -203,9 +203,8 @@ toPatternReport source localizer patternRegion category tipe expected =

203203 "The " <> D.ordinal index <> " argument to `" <> N.toString name <> "` is weird."

204204 , patternTypeComparison localizer tipe expectedType

205205 (addPatternCategory "The argument is a pattern that matches" category)

206− (singular $

207− "But the type annotation on `" <> N.toString name

208− <> "` says the " <> D.ordinal index <> " argument should be"

206+ ( "But the type annotation on `" <> N.toString name

207+ <> "` says the " <> D.ordinal index <> " argument should be:"

209208 )

210209 []

211210 )

@@ -218,7 +217,7 @@ toPatternReport source localizer patternRegion category tipe expected =

218217 ,

219218 patternTypeComparison localizer tipe expectedType

220219 (addPatternCategory "The first pattern is trying to match" category)

221− (singular "But the expression between `case` and `of` is")

220+ "But the expression between `case` and `of` is:"

222221 [ D.reflow $

223222 "These can never match! Is the pattern the problem? Or is it the expression?"

224223 ]

@@ -228,7 +227,7 @@ toPatternReport source localizer patternRegion category tipe expected =

228227 "The " <> D.ordinal index <> " pattern in this `case` does not match the previous ones."

229228 , patternTypeComparison localizer tipe expectedType

230229 (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category)

231− (plural "But all the previous patterns match")

230+ "But all the previous patterns match:"

232231 [ D.link "Note"

233232 "A `case` expression can only handle one type of value, so you may want to use"

234233 "union-types"

@@ -241,9 +240,8 @@ toPatternReport source localizer patternRegion category tipe expected =

241240 "The " <> D.ordinal index <> " argument to `" <> N.toString name <> "` is weird."

242241 , patternTypeComparison localizer tipe expectedType

243242 (addPatternCategory "It is trying to match" category)

244− (singular $

245− "But `" <> N.toString name <> "` needs its "

246− <> D.ordinal index <> " argument to be"

243+ ( "But `" <> N.toString name <> "` needs its "

244+ <> D.ordinal index <> " argument to be:"

247245 )

248246 []

249247 )

@@ -253,7 +251,7 @@ toPatternReport source localizer patternRegion category tipe expected =

253251 "The " <> D.ordinal index <> " pattern in this list does not match all the previous ones:"

254252 , patternTypeComparison localizer tipe expectedType

255253 (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category)

256− (plural "But all the previous patterns in the list are")

254+ "But all the previous patterns in the list are:"

257255 [ D.toSimpleHint $

258256 "Everything in the list needs to be the same type of value.\

259257 \ This way you never run into unexpected values partway through.\

@@ -267,7 +265,7 @@ toPatternReport source localizer patternRegion category tipe expected =

267265 "The pattern after (::) is causing issues."

268266 , patternTypeComparison localizer tipe expectedType

269267 (addPatternCategory "The pattern after (::) is trying to match" category)

270− (\_ -> "But it needs to match lists like this:")

268+ "But it needs to match lists like this:"

271269 []

272270 )

273271

@@ -276,144 +274,96 @@ toPatternReport source localizer patternRegion category tipe expected =

276274-- PATTERN HELPERS

277275

278276

279−patternTypeComparison

280− :: L.Localizer

281− -> T.Type

282− -> T.Type

283− -> (Maybe N.Name -> D.Doc)

284− -> (Maybe N.Name -> D.Doc)

285− -> [D.Doc]

286− -> D.Doc

277+patternTypeComparison :: L.Localizer -> T.Type -> T.Type -> String -> String -> [D.Doc] -> D.Doc

287278patternTypeComparison localizer actual expected iAmSeeing insteadOf contextHints =

288279 let

289− (T.Comparison actualAlias actualDoc expectedAlias expectedDoc problems) =

280+ (actualDoc, expectedDoc, problems) =

290281 T.toComparison localizer actual expected

291282 in

292283 D.stack $

293− [ iAmSeeing actualAlias

284+ [ D.reflow iAmSeeing

294285 , D.indent 4 actualDoc

295− , insteadOf expectedAlias

286+ , D.reflow insteadOf

296287 , D.indent 4 expectedDoc

297288 ]

298289 ++ problemsToHint problems

299290 ++ contextHints

300291

301292

302−addPatternCategory :: String -> PCategory -> Maybe N.Name -> D.Doc

303−addPatternCategory iAmTryingToMatch category maybeAlias =

304− D.reflow $ iAmTryingToMatch <>

305− case maybeAlias of

306− Just alias ->

307− " `" <> N.toString alias <> "` values:"

308−

309− Nothing ->

310− case category of

311− PRecord -> " record values of type:"

312− PUnit -> " unit values:"

313− PTuple -> " tuples of type:"

314− PList -> " lists of type:"

315− PCtor name -> " `" <> N.toString name <> "` values of type:"

316− PInt -> " integers:"

317− PStr -> " strings:"

318− PChr -> " characters:"

293+addPatternCategory :: String -> PCategory -> String

294+addPatternCategory iAmTryingToMatch category =

295+ iAmTryingToMatch <>

296+ case category of

297+ PRecord -> " record values of type:"

298+ PUnit -> " unit values:"

299+ PTuple -> " tuples of type:"

300+ PList -> " lists of type:"

301+ PCtor name -> " `" <> N.toString name <> "` values of type:"

302+ PInt -> " integers:"

303+ PStr -> " strings:"

304+ PChr -> " characters:"

319305

320306

321307

322308-- EXPR HELPERS

323309

324310

325−typeComparison

326− :: L.Localizer

327− -> T.Type

328− -> T.Type

329− -> (Maybe N.Name -> D.Doc)

330− -> (Maybe N.Name -> D.Doc)

331− -> [D.Doc]

332− -> D.Doc

311+typeComparison :: L.Localizer -> T.Type -> T.Type -> String -> String -> [D.Doc] -> D.Doc

333312typeComparison localizer actual expected iAmSeeing insteadOf contextHints =

334313 let

335− (T.Comparison actualAlias actualDoc expectedAlias expectedDoc problems) =

314+ (actualDoc, expectedDoc, problems) =

336315 T.toComparison localizer actual expected

337316 in

338317 D.stack $

339− [ iAmSeeing actualAlias

318+ [ D.reflow iAmSeeing

340319 , D.indent 4 actualDoc

341− , insteadOf expectedAlias

320+ , D.reflow insteadOf

342321 , D.indent 4 expectedDoc

343322 ]

344323 ++ problemsToHint problems

345324 ++ contextHints

346325

347326

348−loneType

349− :: L.Localizer

350− -> T.Type

351− -> T.Type

352− -> (Maybe N.Name -> D.Doc)

353− -> [D.Doc]

354− -> D.Doc

327+loneType :: L.Localizer -> T.Type -> T.Type -> D.Doc -> [D.Doc] -> D.Doc

355328loneType localizer actual expected iAmSeeing furtherDetails =

356329 let

357− (T.Comparison actualAlias actualDoc _ _ problems) =

330+ (actualDoc, _, problems) =

358331 T.toComparison localizer actual expected

359332 in

360333 D.stack $

361− [ iAmSeeing actualAlias

334+ [ iAmSeeing

362335 , D.indent 4 actualDoc

363336 ]

364337 ++ furtherDetails

365338 ++ problemsToHint problems

366339

367340

368−singular :: String -> Maybe N.Name -> D.Doc

369−singular insteadOf maybeAlias =

370− D.reflow $ insteadOf <>

371− case maybeAlias of

372− Nothing -> ":"

373− Just a -> " a `" <> N.toString a <> "` value:"

374−

375−

376−plural :: String -> Maybe N.Name -> D.Doc

377−plural insteadOf maybeAlias =

378− D.reflow $ insteadOf <>

379− case maybeAlias of

380− Nothing -> ":"

381− Just a -> " `" <> N.toString a <> "` values:"

382−

383−

384−addCategory :: String -> Category -> Maybe N.Name -> D.Doc

385−addCategory thisIs category maybeAlias =

386− let

387− definitely whatever =

388− case maybeAlias of

389− Just alias -> " a `" <> N.toString alias <> "`:"

390− Nothing -> whatever

391− in

392− D.reflow $

341+addCategory :: String -> Category -> String

342+addCategory thisIs category =

393343 case category of

394− Local name -> "This `" <> N.toString name <> "` value is" <> definitely " a:"

395− Foreign name -> "This `" <> N.toString name <> "` value is" <> definitely " a:"

396− Access field -> "The value at ." <> N.toString field <> " is" <> definitely " a:"

344+ Local name -> "This `" <> N.toString name <> "` value is a:"

345+ Foreign name -> "This `" <> N.toString name <> "` value is a:"

346+ Access field -> "The value at ." <> N.toString field <> " is a:"

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

398− If -> "This `if` expression produces" <> definitely ":"

399− Case -> "This `case` expression produces" <> definitely ":"

400− List -> thisIs <> definitely " a list of type:"

401− Number -> thisIs <> definitely " a number of type:"

402− Float -> thisIs <> definitely " a float of type:"

403− String -> thisIs <> definitely " a string of type:"

404− Char -> thisIs <> definitely " a character of type:"

405− Lambda -> thisIs <> definitely " an anonymous function of type:"

406− Record -> thisIs <> definitely " a record of type:"

407− Tuple -> thisIs <> definitely " a tuple of type:"

408− Unit -> thisIs <> definitely " a unit value:"

409− Shader -> thisIs <> definitely " a GLSL shader of type:"

348+ If -> "This `if` expression produces:"

349+ Case -> "This `case` expression produces:"

350+ List -> thisIs <> " a list of type:"

351+ Number -> thisIs <> " a number of type:"

352+ Float -> thisIs <> " a float of type:"

353+ String -> thisIs <> " a string of type:"

354+ Char -> thisIs <> " a character of type:"

355+ Lambda -> thisIs <> " an anonymous function of type:"

356+ Record -> thisIs <> " a record of type:"

357+ Tuple -> thisIs <> " a tuple of type:"

358+ Unit -> thisIs <> " a unit value:"

359+ Shader -> thisIs <> " a GLSL shader of type:"

410360 Effects -> thisIs <> " a thing for CORE LIBRARIES ONLY."

411361 CallResult maybeName ->

412362 case maybeName of

413363 NoName -> thisIs <> ":"

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

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

416− OpName _ -> thisIs <> definitely ":"

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

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

366+ OpName _ -> thisIs <> ":"

417367

418368

419369problemsToHint :: [T.Problem] -> [D.Doc]

@@ -531,6 +481,19 @@ problemToHint problem =

531481 T.Tuple _ _ _ -> badRigidSuper super "a tuple"

532482 T.Alias _ n _ _ -> badRigidSuper super ("a `" ++ N.toString n ++ "` value")

533483

484+ T.FieldTypo typo possibilities ->

485+ case Suggest.sort (N.toString typo) N.toString possibilities of

486+ [] ->

487+ []

488+

489+ nearest:_ ->

490+ [ D.toFancyHint $

491+ ["Seems","like","a","record","field","typo.","Maybe"

492+ ,D.dullyellow (D.fromName typo),"should","be"

493+ ,D.green (D.fromName nearest) <> "?"

494+ ]

495+ ]

496+

534497

535498

536499-- BAD RIGID HINTS

@@ -659,7 +622,7 @@ toExprReport source localizer exprRegion category tipe expected =

659622 ( "This expression is being used in an unexpected way:"

660623 , typeComparison localizer tipe expectedType

661624 (addCategory "It is" category)

662− (singular "But you are trying to use it as")

625+ "But you are trying to use it as:"

663626 []

664627 )

665628

@@ -682,7 +645,7 @@ toExprReport source localizer exprRegion category tipe expected =

682645 ( D.reflow ("Something is off with the " <> thing)

683646 , typeComparison localizer tipe expectedType

684647 (addCategory itIs category)

685− (singular $ "But the type annotation on `" <> N.toString name <> "` says it should be")

648+ ("But the type annotation on `" <> N.toString name <> "` says it should be:")

686649 []

687650 )

688651

@@ -699,7 +662,7 @@ toExprReport source localizer exprRegion category tipe expected =

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

700663 Report.toCodeSnippet source region maybeHighlight

701664 ( D.reflow problem

702− , loneType localizer tipe expectedType (addCategory thisIs category) furtherDetails

665+ , loneType localizer tipe expectedType (D.reflow (addCategory thisIs category)) furtherDetails

703666 )

704667

705668 custom maybeHighlight docPair =

@@ -713,7 +676,7 @@ toExprReport source localizer exprRegion category tipe expected =

713676 ( Just exprRegion

714677 , "The " <> ith <> " element of this list does not match all the previous elements:"

715678 , "The " <> ith <> " element is"

716− , plural "But all the previous elements in the list are"

679+ , "But all the previous elements in the list are:"

717680 , [ D.toSimpleHint $

718681 "Everything in the list needs to be the same type of value.\

719682 \ This way you never run into unexpected values partway through.\

@@ -761,7 +724,7 @@ toExprReport source localizer exprRegion category tipe expected =

761724 ( Just exprRegion

762725 , "The " <> ith <> " branch of this `if` does not match all the previous branches:"

763726 , "The " <> ith <> " branch is"

764− , plural "But all the previous branches result in"

727+ , "But all the previous branches result in:"

765728 , [ D.link "Hint"

766729 "All branches in an `if` must produce the same type of values. This way, no\

767730 \ matter which branch we take, the result is always a consistent shape. Read"

@@ -776,7 +739,7 @@ toExprReport source localizer exprRegion category tipe expected =

776739 ( Just exprRegion

777740 , "The " <> ith <> " branch of this `case` does not match all the previous branches:"

778741 , "The " <> ith <> " branch is"

779− , plural "But all the previous branches result in"

742+ , "But all the previous branches result in:"

780743 , [ D.link "Hint"

781744 "All branches in a `case` must produce the same type of values. This way, no\

782745 \ matter which branch we take, the result is always a consistent shape. Read"

@@ -830,7 +793,7 @@ toExprReport source localizer exprRegion category tipe expected =

830793 ( Just exprRegion

831794 , "The " <> ith <> " argument to " <> thisFunction <> " is not what I expect:"

832795 , "This argument is"

833− , singular $ "But " <> thisFunction <> " needs the " <> ith <> " argument to be"

796+ , "But " <> thisFunction <> " needs the " <> ith <> " argument to be:"

834797 ,

835798 if Index.toHuman index == 1 then

836799 []

@@ -884,7 +847,7 @@ toExprReport source localizer exprRegion category tipe expected =

884847 ( Nothing

885848 , "Something is off with this record update:"

886849 , "The `" <> N.toString record <> "` record is"

887− , \_ -> "But this update needs it to be compatable with:"

850+ , "But this update needs it to be compatable with:"

888851 , [ D.reflow

889852 "Do you mind creating an <http://sscce.org/> that produces this error message and\

890853 \ sharing it at <https://github.com/elm-lang/error-message-catalog/issues> so we\

@@ -929,7 +892,7 @@ toExprReport source localizer exprRegion category tipe expected =

929892 ( Just exprRegion

930893 , "I cannot update the `" <> N.toString field <> "` field like this:"

931894 , "You are trying to update `" <> N.toString field <> "` to be"

932− , singular "But it should be"

895+ , "But it should be:"

933896 , [ D.toSimpleNote

934897 "The record update syntax does not allow you to change the type of fields.\

935898 \ You can achieve that with record constructors or the record literal syntax."

@@ -941,7 +904,7 @@ toExprReport source localizer exprRegion category tipe expected =

941904 ( Nothing

942905 , "This definition is causing issues:"

943906 , "You are defining"

944− , singular "But then trying to destructure it as"

907+ , "But then trying to destructure it as:"

945908 , []

946909 )

947910

@@ -1030,7 +993,7 @@ opLeftToDocs localizer category op tipe expected =

1030993 "<|" ->

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

1032995 , loneType localizer tipe expected

1033− (addCategory "I am seeing" category)

996+ (D.reflow (addCategory "I am seeing" category))

1034997 [ D.reflow $ "This needs to be some kind of function though!"

1035998 ]

1036999 )

@@ -1040,7 +1003,7 @@ opLeftToDocs localizer category op tipe expected =

10401003 "The left argument of (" <> N.toString op <> ") is causing problems:"

10411004 , typeComparison localizer tipe expected

10421005 (addCategory "The left argument is" category)

1043− (singular $ "But (" <> N.toString op <> ") needs the left argument to be")

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

10441007 []

10451008 )

10461009

@@ -1101,7 +1064,7 @@ opRightToDocs localizer category op tipe expected =

11011064 ( D.reflow $ "I cannot send this through the (<|) pipe:"

11021065 , typeComparison localizer tipe expected

11031066 (addCategory "You are providing" category)

1104− (singular "But (<|) is piping it a function that expects")

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

11051068 []

11061069 )

11071070

@@ -1112,7 +1075,7 @@ opRightToDocs localizer category op tipe expected =

11121075 ( D.reflow $ "This function cannot handle the argument sent through the (|>) pipe:"

11131076 , typeComparison localizer argType expectedArgType

11141077 (addCategory "The argument is" category)

1115− (singular "But (|>) is piping it a function that expects")

1078+ "But (|>) is piping it a function that expects:"

11161079 []

11171080 )

11181081

@@ -1120,7 +1083,7 @@ opRightToDocs localizer category op tipe expected =

11201083 EmphRight

11211084 ( D.reflow $ "The right side of (|>) needs to be a function so I can pipe arguments to it!"

11221085 , loneType localizer tipe expected

1123− (addCategory "But instead of a function, I am seeing" category)

1086+ (D.reflow (addCategory "But instead of a function, I am seeing" category))

11241087 []

11251088 )

11261089

@@ -1135,7 +1098,7 @@ badOpRightFallback localizer category op tipe expected =

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

11361099 , typeComparison localizer tipe expected

11371100 (addCategory "The right argument is" category)

1138− (singular $ "But (" <> N.toString op <> ") needs the right argument to be")

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

11391102 [ D.toSimpleHint $

11401103 "With operators like (" ++ N.toString op ++ ") I always check the left\

11411104 \ side first. If it seems fine, I assume it is correct and check the right\

@@ -1197,8 +1160,8 @@ badConsRight localizer category tipe expected =

11971160 EmphBoth

11981161 ( D.reflow "I am having trouble with this (::) operator:"

11991162 , typeComparison localizer expectedElement actualElement

1200− (singular "The left side of (::) is")

1201− (plural "But you are trying to put that into a list filled with")

1163+ "The left side of (::) is:"

1164+ "But you are trying to put that into a list filled with:"

12021165 ( case expectedElement of

12031166 T.Type home name [_] | T.isList home name ->

12041167 [ D.toSimpleHint

@@ -1221,7 +1184,7 @@ badConsRight localizer category tipe expected =

12211184 EmphRight

12221185 ( D.reflow "The (::) operator can only add elements onto lists."

12231186 , loneType localizer tipe expected

1224− (addCategory "The right side is" category)

1187+ (D.reflow (addCategory "The right side is" category))

12251188 [D.fillSep ["But","(::)","needs","a",D.dullyellow "List","on","the","right."]

12261189 ]

12271190 )

@@ -1271,7 +1234,7 @@ badAppendLeft localizer category tipe expected =

12711234 ( D.reflow $

12721235 "The (++) operator cannot append this type of value:"

12731236 , loneType localizer tipe expected

1274− (addCategory "I am seeing" category)

1237+ (D.reflow (addCategory "I am seeing" category))

12751238 [ D.fillSep

12761239 ["But","the","(++)","operator","is","only","for","appending"

12771240 ,D.dullyellow "List","and",D.dullyellow "String","values."

@@ -1330,7 +1293,7 @@ badAppendRight localizer category tipe expected =

13301293 ( D.reflow $

13311294 "The (++) operator cannot append these two values:"

13321295 , typeComparison localizer expected tipe

1333− (singular "I already figured out that the left side of (++) is")

1296+ "I already figured out that the left side of (++) is:"

13341297 (addCategory "But this clashes with the right side, which is" category)

13351298 []

13361299 )

@@ -1402,7 +1365,7 @@ badListAdd localizer category direction tipe expected =

14021365 "I cannot do addition with lists:"

14031366 ,

14041367 loneType localizer tipe expected

1405− (addCategory ("The " <> direction <> " side of (+) is") category)

1368+ (D.reflow (addCategory ("The " <> direction <> " side of (+) is") category))

14061369 [ D.fillSep

14071370 ["But","(+)","only","works","with",D.dullyellow "Int","and",D.dullyellow "Float","values."

14081371 ]

@@ -1432,7 +1395,7 @@ badMath localizer category operation direction op tipe expected otherHints =

14321395 operation ++ " does not work with this value:"

14331396 ,

14341397 loneType localizer tipe expected

1435− (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category)

1398+ (D.reflow (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category))

14361399 ( [ D.fillSep

14371400 ["But","(" <> D.fromString op <> ")","only","works","with"

14381401 ,D.dullyellow "Int","and",D.dullyellow "Float","values."

@@ -1466,11 +1429,10 @@ badFDiv localizer direction tipe expected =

14661429

14671430 else

14681431 loneType localizer tipe expected

1469− (\_ ->

1470− D.fillSep

1471− ["The",direction,"side","of","(/)","must","be","a"

1472− ,D.dullyellow "Float" <> ",","but","instead","I","am","seeing:"

1473− ]

1432+ (D.fillSep

1433+ ["The",direction,"side","of","(/)","must","be","a"

1434+ ,D.dullyellow "Float" <> ",","but","instead","I","am","seeing:"

1435+ ]

14741436 )

14751437 []

14761438 )

@@ -1501,11 +1463,10 @@ badIDiv localizer direction tipe expected =

15011463 ]

15021464 else

15031465 loneType localizer tipe expected

1504− ( \_ ->

1505− D.fillSep

1506− ["The",direction,"side","of","(//)","must","be","an"

1507− ,D.dullyellow "Int" <> ",","but","instead","I","am","seeing:"

1508− ]

1466+ ( D.fillSep

1467+ ["The",direction,"side","of","(//)","must","be","an"

1468+ ,D.dullyellow "Int" <> ",","but","instead","I","am","seeing:"

1469+ ]

15091470 )

15101471 []

15111472 )

@@ -1522,11 +1483,10 @@ badBool localizer op direction tipe expected =

15221483 "I am struggling with this boolean operation:"

15231484 ,

15241485 loneType localizer tipe expected

1525− ( \_ ->

1526− D.fillSep

1527− ["Both","sides","of","(" <> op <> ")","must","be"

1528− ,D.dullyellow "Bool","values,","but","the",direction,"side","is:"

1529− ]

1486+ ( D.fillSep

1487+ ["Both","sides","of","(" <> op <> ")","must","be"

1488+ ,D.dullyellow "Bool","values,","but","the",direction,"side","is:"

1489+ ]

15301490 )

15311491 []

15321492 )

@@ -1543,7 +1503,7 @@ badCompLeft localizer category op direction tipe expected =

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

15441504 ,

15451505 loneType localizer tipe expected

1546− (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category)

1506+ (D.reflow (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category))

15471507 [ D.fillSep

15481508 ["But","(" <> D.fromString op <> ")","only","works","on"

15491509 ,D.dullyellow "Int" <> ","

@@ -1567,8 +1527,8 @@ badCompRight localizer op tipe expected =

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

15681528 ,

15691529 typeComparison localizer expected tipe

1570− (singular "The left side of is")

1571− (singular "But the right side is")

1530+ "The left side of is:"

1531+ "But the right side is:"

15721532 [ D.reflow $

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

15741534 ]

@@ -1587,8 +1547,8 @@ badEquality localizer op tipe expected =

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

15881548 ,

15891549 typeComparison localizer expected tipe

1590− (singular "The left side of is")

1591− (singular "But the right side is")

1550+ "The left side of is:"

1551+ "But the right side is:"

15921552 [ if isFloat tipe || isFloat expected then

15931553 D.toSimpleNote $

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

compiler/src/Type/Error.hs+329−459

@@ -5,9 +5,7 @@ module Type.Error

55 , Super(..)

66 , Extension(..)

77 , iteratedDealias

8− , getFields

98 , toDoc

10− , Comparison(..)

119 , Problem(..)

1210 , toComparison

1311 , isInt

@@ -73,19 +71,6 @@ iteratedDealias tipe =

7371 tipe

7472

7573

76−getFields :: Type -> Maybe (Map.Map N.Name Type)

77−getFields tipe =

78− case tipe of

79− Alias _ _ _ real ->

80− getFields real

81−

82− Record fields _ ->

83− Just fields

84−

85− _ ->

86− Nothing

87−

88−

8974

9075-- TO DOC

9176

@@ -128,18 +113,7 @@ toDoc localizer ctx tipe =

128113 (map (toDoc localizer RT.App) args)

129114

130115 Record fields ext ->

131− let

132− entryToDocs (fieldName, fieldType) =

133− ( D.fromName fieldName, toDoc localizer RT.None fieldType )

134−

135− fieldDocs =

136− map entryToDocs (Map.toList fields)

137− in

138− RT.record fieldDocs $

139− case ext of

140− Closed -> Nothing

141− FlexOpen x -> Just (D.fromName x)

142− RigidOpen x -> Just (D.fromName x)

116+ RT.record (fieldsToDocs localizer fields) (extToDoc ext)

143117

144118 Unit ->

145119 "()"

@@ -151,288 +125,251 @@ toDoc localizer ctx tipe =

151125 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))

152126

153127 Alias home name args _ ->

154− RT.apply ctx

155− (nameToDoc localizer home name)

156− (map (toDoc localizer RT.App . snd) args)

128+ aliasToDoc localizer ctx home name args

157129

158130

131+aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Type)] -> D.Doc

132+aliasToDoc localizer ctx home name args =

133+ RT.apply ctx

134+ (nameToDoc localizer home name)

135+ (map (toDoc localizer RT.App . snd) args)

159136

160−-- DIFF

161137

138+fieldsToDocs :: L.Localizer -> Map.Map N.Name Type -> [(D.Doc, D.Doc)]

139+fieldsToDocs localizer fields =

140+ Map.foldrWithKey (addField localizer) [] fields

162141

163−data Diff

164− = Similar Type Type

165− | DiffLambda Aliases Diff Diff [Diff]

166− | DiffType Aliases ModuleName.Canonical N.Name [Diff]

167− | DiffRecord Aliases [N.Name] (Map.Map N.Name Diff) [N.Name] Extension Extension

168− | DiffTuple Aliases Diff Diff (Maybe Diff)

169− | Clash Type Type

170142

143+addField :: L.Localizer -> N.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)]

144+addField localizer fieldName fieldType docs =

145+ let

146+ f = D.fromName fieldName

147+ t = toDoc localizer RT.None fieldType

148+ in

149+ (f,t) : docs

171150

172−same :: Type -> Diff

173−same tipe =

174− Similar tipe tipe

175151

152+extToDoc :: Extension -> Maybe D.Doc

153+extToDoc ext =

154+ case ext of

155+ Closed -> Nothing

156+ FlexOpen x -> Just (D.fromName x)

157+ RigidOpen x -> Just (D.fromName x)

176158

177−data Aliases =

178− Aliases

179− { _left :: Maybe N.Name

180− , _right :: Maybe N.Name

181− }

182159

183160

184−{-# NOINLINE noAliases #-}

185−noAliases :: Aliases

186−noAliases =

187− Aliases Nothing Nothing

161+-- DIFF

188162

189163

190−toDiff :: Type -> Type -> Diff

191−toDiff t1 t2 =

192− case (t1, t2) of

193− (Unit , Unit ) -> same t1

194− (Error , Error ) -> same t1

195− (Infinite, Infinite) -> same t1

164+data Diff a =

165+ Diff a a Status

196166

197− (FlexVar x, FlexVar y) | x == y -> same t1

198− (FlexSuper _ x, FlexSuper _ y) | x == y -> same t1

199− (RigidVar x, RigidVar y) | x == y -> same t1

200− (RigidSuper _ x, RigidSuper _ y) | x == y -> same t1

201167

202− (FlexVar _ , _ ) -> Similar t1 t2

203− (_ , FlexVar _ ) -> Similar t1 t2

168+data Status

169+ = Similar

170+ | Different (Bag.Bag Problem)

204171

205− (Lambda a1 b1 cs1, Lambda a2 b2 cs2) | length cs1 == length cs2 ->

206− let

207− a = toDiff a1 a2

208− b = toDiff b1 b2

209− cs = zipWith toDiff cs1 cs2

210− in

211− if isSimilar a && isSimilar b && all isSimilar cs

212− then Similar t1 t2

213− else DiffLambda noAliases a b cs

214172

215− (Tuple a1 b1 Nothing, Tuple a2 b2 Nothing) ->

216− let

217− a = toDiff a1 a2

218− b = toDiff b1 b2

219− in

220− if isSimilar a && isSimilar b

221− then Similar t1 t2

222− else DiffTuple noAliases a b Nothing

173+data Problem

174+ = IntFloat

175+ | StringFromInt

176+ | StringFromFloat

177+ | StringToInt

178+ | StringToFloat

179+ | AnythingToBool

180+ | AnythingFromMaybe

181+ | AnythingToList

182+ | MissingArgs Int

183+ | ReturnMismatch

184+ | BadFlexSuper Super N.Name Type

185+ | BadRigidVar N.Name Type

186+ | BadRigidSuper Super N.Name Type

187+ | FieldTypo N.Name [N.Name]

223188

224− (Tuple a1 b1 (Just c1), Tuple a2 b2 (Just c2)) ->

225− let

226− a = toDiff a1 a2

227− b = toDiff b1 b2

228− c = toDiff c1 c2

229− in

230− if isSimilar a && isSimilar b && isSimilar c

231− then Similar t1 t2

232− else DiffTuple noAliases a b (Just c)

233189

234− (Record fields1 ext1, Record fields2 ext2) ->

235− let

236− left = Map.keys (Map.difference fields1 fields2)

237− both = Map.intersectionWith toDiff fields1 fields2

238− right = Map.keys (Map.difference fields2 fields1)

239− in

240− if null left && null right && all isSimilar both && isExtSimilar ext1 ext2

241− then Similar t1 t2

242− else DiffRecord noAliases left both right ext1 ext2

190+instance Functor Diff where

191+ fmap func (Diff a b status) =

192+ Diff (func a) (func b) status

243193

244− (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->

245− let

246− args = zipWith toDiff args1 args2

247− in

248− if all isSimilar args

249− then Similar t1 t2

250− else DiffType noAliases home1 name1 args

251194

252− (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->

253− let

254− args = zipWith toDiff (map snd args1) (map snd args2)

255− in

256− if all isSimilar args

257− then Similar t1 t2

258− else DiffType noAliases home1 name1 args

195+instance Applicative Diff where

196+ pure a =

197+ Diff a a Similar

259198

260− (alias@(Alias _ name _ tipe1), tipe2) ->

261− addAlias (const alias) id (\(Aliases _ t) -> Aliases (Just name) t) (toDiff tipe1 tipe2)

199+ (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =

200+ Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)

262201

263− (tipe1, alias@(Alias _ name _ tipe2)) ->

264− addAlias id (const alias) (\(Aliases t _) -> Aliases t (Just name)) (toDiff tipe1 tipe2)

265202

266− _ ->

267− Clash t1 t2

203+merge :: Status -> Status -> Status

204+merge status1 status2 =

205+ case status1 of

206+ Similar ->

207+ status2

268208

209+ Different problems1 ->

210+ case status2 of

211+ Similar ->

212+ status1

269213

270−isSimilar :: Diff -> Bool

271−isSimilar diff =

272− case diff of

273− Similar _ _ -> True

274− DiffLambda _ _ _ _ -> False

275− DiffType _ _ _ _ -> False

276− DiffRecord _ _ _ _ _ _ -> False

277− DiffTuple _ _ _ _ -> False

278− Clash _ _ -> False

214+ Different problems2 ->

215+ Different (Bag.append problems1 problems2)

279216

280217

281−addAlias :: (Type -> Type) -> (Type -> Type) -> (Aliases -> Aliases) -> Diff -> Diff

282−addAlias updateLeft updateRight updateAliases diff =

283− case diff of

284− Similar t1 t2 ->

285− Similar (updateLeft t1) (updateRight t2)

286218

287− DiffLambda aliases a b cs ->

288− DiffLambda (updateAliases aliases) a b cs

219+-- COMPARISON

289220

290− DiffType aliases home name args ->

291− DiffType (updateAliases aliases) home name args

292221

293− DiffRecord aliases lefts boths rights ext1 ext2 ->

294− DiffRecord (updateAliases aliases) lefts boths rights ext1 ext2

222+toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])

223+toComparison localizer tipe1 tipe2 =

224+ case toDiff localizer RT.None tipe1 tipe2 of

225+ Diff doc1 doc2 Similar ->

226+ (doc1, doc2, [])

295227

296− DiffTuple aliases a b maybeC ->

297− DiffTuple (updateAliases aliases) a b maybeC

228+ Diff doc1 doc2 (Different problems) ->

229+ (doc1, doc2, Bag.toList problems)

298230

299− Clash t1 t2 ->

300− Clash (updateLeft t1) (updateRight t2)

301231

232+toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc

233+toDiff localizer ctx tipe1 tipe2 =

234+ case (tipe1, tipe2) of

235+ (Unit , Unit ) -> same localizer ctx tipe1

236+ (Error , Error ) -> same localizer ctx tipe1

237+ (Infinite, Infinite) -> same localizer ctx tipe1

302238

239+ (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1

240+ (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1

241+ (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1

242+ (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1

303243

304−-- COMPARISON

244+ (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2

245+ (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2

305246

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

248+ if length cs == length zs then

249+ RT.lambda ctx

250+ <$> toDiff localizer RT.Func a x

251+ <*> toDiff localizer RT.Func b y

252+ <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)

253+ else

254+ diffLambda localizer ctx a b cs x y zs

306255

307−data Comparison =

308− Comparison

309− { _alias1 :: Maybe N.Name

310− , _type1 :: D.Doc

311− , _alias2 :: Maybe N.Name

312− , _type2 :: D.Doc

313− , _problems :: [Problem]

314− }

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

257+ RT.tuple

258+ <$> toDiff localizer RT.None a x

259+ <*> toDiff localizer RT.None b y

260+ <*> pure []

315261

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

263+ RT.tuple

264+ <$> toDiff localizer RT.None a x

265+ <*> toDiff localizer RT.None b y

266+ <*> ((:[]) <$> toDiff localizer RT.None c z)

316267

317−data Problem

318− = FieldMismatch [N.Name] [N.Name]

319− | IntFloat

320− | StringFromInt

321− | StringFromFloat

322− | StringToInt

323− | StringToFloat

324− | AnythingToBool

325− | AnythingFromMaybe

326− | AnythingToList

327− | MissingArgs Int

328− | ReturnMismatch

329− | BadFlexSuper Super N.Name Type

330− | BadRigidVar N.Name Type

331− | BadRigidSuper Super N.Name Type

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

269+ diffRecord localizer fields1 ext1 fields2 ext2

332270

271+ (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->

272+ RT.apply ctx (nameToDoc localizer home1 name1)

273+ <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2)

333274

334−toComparison :: L.Localizer -> Type -> Type -> Comparison

335−toComparison localizer a b =

336− let

337− diff = toDiff a b

338− (Aliases aAlias bAlias) = getAliases diff

339− (Pair aDoc bDoc problems) = diffToPair localizer RT.None diff

340− in

341− Comparison aAlias aDoc bAlias bDoc (Bag.toList problems)

275+ (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->

276+ RT.apply ctx (nameToDoc localizer home1 name1)

277+ <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2))

342278

279+ -- start trying to find specific problems

343280

344−getAliases :: Diff -> Aliases

345−getAliases diff =

346− case diff of

347− Similar _ _ -> noAliases

348− DiffLambda aliases _ _ _ -> aliases

349− DiffType aliases _ _ _ -> aliases

350− DiffRecord aliases _ _ _ _ _ -> aliases

351− DiffTuple aliases _ _ _ -> aliases

352− Clash _ _ -> noAliases

281+ (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->

282+ different

283+ (RT.apply ctx (D.dullyellow (nameToDoc localizer home name)) [toDoc localizer RT.App t1])

284+ (toDoc localizer ctx t2)

285+ (Bag.one AnythingFromMaybe)

353286

287+ (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->

288+ different

289+ (toDoc localizer ctx t1)

290+ (RT.apply ctx (D.dullyellow (nameToDoc localizer home name)) [toDoc localizer RT.App t2])

291+ (Bag.one AnythingToList)

354292

293+ (Alias home name args t1, t2) ->

294+ case diffAliasedRecord localizer t1 t2 of

295+ Just (Diff _ doc2 status) ->

296+ Diff (D.dullyellow (aliasToDoc localizer ctx home name args)) doc2 status

355297

356−-- DIFF TO DOCS

298+ Nothing ->

299+ different

300+ (D.dullyellow (toDoc localizer ctx tipe1))

301+ (D.dullyellow (toDoc localizer ctx tipe2))

302+ Bag.empty

357303

304+ (t1, Alias home name args t2) ->

305+ case diffAliasedRecord localizer t1 t2 of

306+ Just (Diff doc1 _ status) ->

307+ Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home name args)) status

358308

359−data Pair a =

360− Pair a a (Bag.Bag Problem)

309+ Nothing ->

310+ different

311+ (D.dullyellow (toDoc localizer ctx tipe1))

312+ (D.dullyellow (toDoc localizer ctx tipe2))

313+ Bag.empty

361314

315+ pair ->

316+ let

317+ doc1 = D.dullyellow (toDoc localizer ctx tipe1)

318+ doc2 = D.dullyellow (toDoc localizer ctx tipe2)

319+ in

320+ different doc1 doc2 $

321+ case pair of

322+ (RigidVar x, other) -> Bag.one $ BadRigidVar x other

323+ (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other

324+ (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other

325+ (other, RigidVar x) -> Bag.one $ BadRigidVar x other

326+ (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other

327+ (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other

362328

363−instance Functor Pair where

364− fmap func (Pair a b ps) =

365− Pair (func a) (func b) ps

329+ (Type home1 name1 [], Type home2 name2 [])

330+ | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat

331+ | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat

332+ | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt

333+ | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat

334+ | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt

335+ | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat

336+ | isBool home2 name2 -> Bag.one AnythingToBool

366337

338+ (_, _) ->

339+ Bag.empty

367340

368−instance Applicative Pair where

369− pure a =

370− Pair a a Bag.empty

371341

372− (<*>) (Pair aFunc bFunc ps1) (Pair aArg bArg ps2) =

373− Pair (aFunc aArg) (bFunc bArg) (Bag.append ps1 ps2)

374342

343+-- DIFF HELPERS

375344

376−diffToPair :: L.Localizer -> RT.Context -> Diff -> Pair D.Doc

377−diffToPair localizer ctx diff =

378− case diff of

379− Similar tipe1 tipe2 ->

380− Pair (toDoc localizer ctx tipe1) (toDoc localizer ctx tipe2) Bag.empty

381345

382− DiffLambda _ a b cs ->

383− RT.lambda ctx

384− <$> diffToPair localizer RT.Func a

385− <*> diffToPair localizer RT.Func b

386− <*> traverse (diffToPair localizer RT.Func) cs

346+same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc

347+same localizer ctx tipe =

348+ let

349+ doc = toDoc localizer ctx tipe

350+ in

351+ Diff doc doc Similar

387352

388− DiffType _ home name args ->

389− RT.apply ctx (nameToDoc localizer home name)

390− <$> traverse (diffToPair localizer RT.App) args

391353

392− DiffRecord _ left both right ext1 ext2 ->

393− diffRecord localizer left both right ext1 ext2

354+similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc

355+similar localizer ctx t1 t2 =

356+ Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar

357+

358+

359+different :: a -> a -> Bag.Bag Problem -> Diff a

360+different a b problems =

361+ Diff a b (Different problems)

362+

363+

364+isSimilar :: Diff a -> Bool

365+isSimilar (Diff _ _ status) =

366+ case status of

367+ Similar -> True

368+ Different _ -> False

394369

395− DiffTuple _ a b maybeC ->

396− RT.tuple

397− <$> diffToPair localizer RT.None a

398− <*> diffToPair localizer RT.None b

399− <*> traverse (diffToPair localizer RT.None) (Maybe.maybeToList maybeC)

400−

401− Clash tipe1 tipe2 ->

402− case (tipe1, tipe2) of

403− (Lambda a b cs, Lambda x y zs) ->

404− diffLambda localizer ctx (a:b:cs) (x:y:zs)

405−

406− (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff t1 t2) ->

407− Pair (yellowApply localizer ctx home name t1) (toDoc localizer ctx t2) (Bag.one AnythingFromMaybe)

408−

409− (t1, Type home name [t2]) | isList home name && isSimilar (toDiff t1 t2) ->

410− Pair (toDoc localizer ctx t1) (yellowApply localizer ctx home name t2) (Bag.one AnythingToList)

411−

412− pair ->

413− let

414− doc1 = D.dullyellow (toDoc localizer ctx tipe1)

415− doc2 = D.dullyellow (toDoc localizer ctx tipe2)

416− in

417− Pair doc1 doc2 $

418− case pair of

419− (RigidVar x, other) -> Bag.one $ BadRigidVar x other

420− (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other

421− (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other

422− (other, RigidVar x) -> Bag.one $ BadRigidVar x other

423− (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other

424− (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other

425−

426− (Type home1 name1 [], Type home2 name2 [])

427− | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat

428− | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat

429− | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt

430− | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat

431− | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt

432− | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat

433− | isBool home2 name2 -> Bag.one AnythingToBool

434−

435− (_, _) -> Bag.empty

370+

371+

372+-- IS TYPE?

436373

437374

438375isBool :: ModuleName.Canonical -> N.Name -> Bool

@@ -470,11 +407,18 @@ isList home name =

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

471408

472409

473−yellowApply :: L.Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> D.Doc

474−yellowApply localizer ctx home name tipe =

475− RT.apply ctx

476− (D.dullyellow (nameToDoc localizer home name))

477− [toDoc localizer RT.App tipe]

410+

411+-- DIFF ALIASED RECORD

412+

413+

414+diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)

415+diffAliasedRecord localizer t1 t2 =

416+ case (iteratedDealias t1, iteratedDealias t2) of

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

418+ Just (diffRecord localizer fields1 ext1 fields2 ext2)

419+

420+ _ ->

421+ Nothing

478422

479423

480424

@@ -483,83 +427,72 @@ yellowApply localizer ctx home name tipe =

483427

484428--

485429-- INVARIANTS:

486−-- length types1 >= 2

487−-- length types2 >= 2

488−-- length types1 /= length types2

430+-- length cs1 /= length cs2

489431--

490−diffLambda :: L.Localizer -> RT.Context -> [Type] -> [Type] -> Pair D.Doc

491−diffLambda localizer ctx types1 types2 =

432+diffLambda :: L.Localizer -> RT.Context -> Type -> Type -> [Type] -> Type -> Type -> [Type] -> Diff D.Doc

433+diffLambda localizer ctx a1 b1 cs1 a2 b2 cs2 =

492434 let

493− (result1:revArgs1) = reverse types1

494− (result2:revArgs2) = reverse types2

435+ (result1:revArgs1) = reverse (a1:b1:cs1)

436+ (result2:revArgs2) = reverse (a2:b2:cs2)

495437

496438 numArgs1 = length revArgs1

497439 numArgs2 = length revArgs2

498−

499− diff = toDiff result1 result2

500−

501− (Pair r1 r2 _) = diffToPair localizer RT.Func diff

502440 in

503− if isSimilar diff then

441+ case toDiff localizer RT.Func result1 result2 of

442+ Diff resultDoc1 resultDoc2 Similar ->

443+ if numArgs1 < numArgs2 then

444+ diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2

504445

505− if numArgs1 < numArgs2 then

506− diffArgMismatch localizer ctx revArgs1 r1 revArgs2 r2

507− else

508− diffArgMismatch localizer ctx revArgs2 r2 revArgs1 r1

446+ else

447+ diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1

509448

510− else

511− let

512− (a1:b1:cs1) = reverse (r1 : map (toDoc localizer RT.Func) revArgs1)

513− (a2:b2:cs2) = reverse (r2 : map (toDoc localizer RT.Func) revArgs2)

514− in

515− Pair

516− (D.dullyellow (RT.lambda ctx a1 b1 cs1))

517− (D.dullyellow (RT.lambda ctx a2 b2 cs2))

518− (Bag.one ReturnMismatch)

449+ Diff resultDoc1 resultDoc2 (Different problems) ->

450+ let

451+ (a:b:cs) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)

452+ (x:y:zs) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)

453+ in

454+ different

455+ (D.dullyellow (RT.lambda ctx a b cs))

456+ (D.dullyellow (RT.lambda ctx x y zs))

457+ (Bag.append problems (Bag.one ReturnMismatch))

519458

520459

521460--

522461-- INVARIANTS:

523462-- length shortRevArgs >= 2

524463-- length longRevArgs >= 2

464+-- length shortRevArgs < length longRevArgs

525465--

526−diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Pair D.Doc

466+diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc

527467diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =

528− case toGreedyMatch localizer shortRevArgs longRevArgs of

529− Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->

530− let

531− (a:b:cs) = reverse (shortResult:shortRevArgDocs)

532− (x:y:zs) = reverse (longResult:longRevArgDocs)

533− in

534− Pair

535− (RT.lambda ctx a b cs)

536− (RT.lambda ctx x y zs)

537− (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))

538−

539− Nothing ->

540− case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of

541− Just (GreedyMatch shortArgDocs longArgDocs) ->

542− let

543− (a:b:cs) = shortArgDocs ++ [shortResult]

544− (x:y:zs) = longArgDocs ++ [longResult]

545− in

546− Pair

547− (RT.lambda ctx a b cs)

548− (RT.lambda ctx x y zs)

549− (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))

468+ let

469+ (a:b:cs, x:y:zs) =

470+ case toGreedyMatch localizer shortRevArgs longRevArgs of

471+ Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->

472+ ( reverse (shortResult:shortRevArgDocs)

473+ , reverse (longResult:longRevArgDocs)

474+ )

550475

551476 Nothing ->

552− let

553− toYellowDoc tipe =

554− D.dullyellow (toDoc localizer RT.Func tipe)

555−

556− (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)

557− (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )

558− in

559− Pair

560− (RT.lambda ctx a b cs)

561− (RT.lambda ctx x y zs)

562− (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))

477+ case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of

478+ Just (GreedyMatch shortArgDocs longArgDocs) ->

479+ ( shortArgDocs ++ [shortResult]

480+ , longArgDocs ++ [longResult]

481+ )

482+

483+ Nothing ->

484+ let

485+ toYellowDoc tipe =

486+ D.dullyellow (toDoc localizer RT.Func tipe)

487+ in

488+ ( reverse (shortResult : map toYellowDoc shortRevArgs)

489+ , reverse (longResult : map toYellowDoc longRevArgs )

490+ )

491+ in

492+ different

493+ (RT.lambda ctx a b cs)

494+ (RT.lambda ctx x y zs)

495+ (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))

563496

564497

565498

@@ -587,14 +520,12 @@ toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDoc

587520 in

588521 case (shorterArgs, longerArgs) of

589522 (x:xs, y:ys) ->

590− case toDiff x y of

591− Similar a b ->

523+ case toDiff localizer RT.Func x y of

524+ Diff a b Similar ->

592525 toGreedyMatchHelp localizer xs ys $

593− GreedyMatch

594− (toDoc localizer RT.Func a : shorterDocs)

595− (toDoc localizer RT.Func b : longerDocs)

526+ GreedyMatch (a:shorterDocs) (b:longerDocs)

596527

597− _ ->

528+ Diff _ _ (Different _) ->

598529 toGreedyMatchHelp localizer shorterArgs ys $

599530 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)

600531

@@ -612,165 +543,104 @@ toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDoc

612543-- RECORD DIFFS

613544

614545

615−diffRecord

616− :: L.Localizer

617− -> [N.Name]

618− -> Map.Map N.Name Diff

619− -> [N.Name]

620− -> Extension

621− -> Extension

622− -> Pair D.Doc

623−diffRecord localizer only1 both only2 ext1 ext2 =

624− if null only1 && null only2 then

625− case findBadOverlaps localizer both of

626− [] ->

627− case diffExt ext1 ext2 of

628− ExtSimilar ->

629− Pair

630− (toBoringRecord (Map.size both) ext1)

631− (toBoringRecord (Map.size both) ext2)

632− Bag.empty

633−

634− ExtDifferent maybeExt1 maybeExt2 problems ->

635− Pair

636− (RT.record [] (fmap (D.dullyellow . D.fromName) maybeExt1))

637− (RT.record [] (fmap (D.dullyellow . D.fromName) maybeExt2))

638− problems

639−

640− overlaps@(bad:bads) ->

641− if length overlaps < Map.size both then

642− Pair

643− (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))

644− (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))

645− (foldr Bag.append Bag.empty (map _problemBag overlaps))

646− else

647− Pair

648− (toOverlapRecord _doc1 bad bads ext1)

649− (toOverlapRecord _doc2 bad bads ext2)

650− (foldr Bag.append Bag.empty (map _problemBag overlaps))

651−

652− else

653− Pair

654− (toMissingDoc (Map.size both) only1 ext1)

655− (toMissingDoc (Map.size both) only2 ext2)

656− (Bag.one (FieldMismatch only1 only2))

657−

658−

659−toOverlapDoc :: (BadOverlap -> D.Doc) -> BadOverlap -> (D.Doc, D.Doc)

660−toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =

661− (D.fromName field, getDoc overlap)

662−

663−

664−toOverlapRecord :: (BadOverlap -> D.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> D.Doc

665−toOverlapRecord getDoc bad bads ext =

666− let go = toOverlapDoc getDoc in

667− case ext of

668− Closed -> RT.record (map go (bad:bads)) Nothing

669− FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)

670− RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)

671−

672−

673−toMissingDoc :: Int -> [N.Name] -> Extension -> D.Doc

674−toMissingDoc numSharedFields uniqueFields ext =

675− case map emphasizeFieldName uniqueFields of

676− [] ->

677− toBoringRecord numSharedFields ext

678−

679− doc:docs ->

680− if length uniqueFields < numSharedFields then

681− RT.recordSnippet doc docs

682− else

683− case ext of

684− Closed -> RT.record (doc:docs) Nothing

685− FlexOpen _ -> RT.recordSnippet doc docs

686− RigidOpen _ -> RT.recordSnippet doc docs

687−

546+diffRecord :: L.Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff D.Doc

547+diffRecord localizer fields1 ext1 fields2 ext2 =

548+ let

549+ toUnknownDocs field tipe =

550+ ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )

688551

689−emphasizeFieldName :: N.Name -> (D.Doc, D.Doc)

690−emphasizeFieldName field =

691− ( D.dullyellow (D.fromName field), "..." )

552+ toOverlapDocs field t1 t2 =

553+ (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2

692554

555+ left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)

556+ both = Map.intersectionWithKey toOverlapDocs fields1 fields2

557+ right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)

693558

694−toBoringRecord :: Int -> Extension -> D.Doc

695−toBoringRecord numFields ext =

559+ fieldsDiff =

560+ Map.elems <$>

561+ if Map.null left && Map.null right then

562+ sequenceA both

563+ else

564+ Map.union

565+ <$> sequenceA both

566+ <*> Diff left right (Different Bag.empty)

567+

568+ (Diff doc1 doc2 status) =

569+ RT.record

570+ <$> fieldsDiff

571+ <*> extToDiff ext1 ext2

572+ in

573+ Diff doc1 doc2 $ merge status $

574+ case (hasFixedFields ext1, hasFixedFields ext2) of

575+ (True, True) ->

576+ case Map.lookupMin left of

577+ Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)

578+ Nothing ->

579+ case Map.lookupMin right of

580+ Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)

581+ Nothing -> Similar

582+

583+ (False, True) ->

584+ case Map.lookupMin left of

585+ Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)

586+ Nothing -> Similar

587+

588+ (True, False) ->

589+ case Map.lookupMin right of

590+ Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)

591+ Nothing -> Similar

592+

593+ (False, False) ->

594+ Similar

595+

596+

597+hasFixedFields :: Extension -> Bool

598+hasFixedFields ext =

696599 case ext of

697− Closed -> if numFields == 0 then "{}" else "{ ... }"

698− FlexOpen _ -> "{ ... }"

699− RigidOpen _ -> "{ ... }"

600+ Closed -> True

601+ FlexOpen _ -> False

602+ RigidOpen _ -> True

700603

701604

702605

703606-- DIFF RECORD EXTENSION

704607

705608

706−isExtSimilar :: Extension -> Extension -> Bool

707−isExtSimilar ext1 ext2 =

708− case diffExt ext1 ext2 of

709− ExtSimilar ->

710− True

711−

712− ExtDifferent _ _ _ ->

713− False

714−

609+extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)

610+extToDiff ext1 ext2 =

611+ let

612+ status = extToStatus ext1 ext2

613+ extDoc1 = extToDoc ext1

614+ extDoc2 = extToDoc ext2

615+ in

616+ case status of

617+ Similar ->

618+ Diff extDoc1 extDoc2 status

715619

716−data ExtDiff

717− = ExtSimilar

718− | ExtDifferent (Maybe N.Name) (Maybe N.Name) (Bag.Bag Problem)

620+ Different _ ->

621+ Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status

719622

720623

721−diffExt :: Extension -> Extension -> ExtDiff

722−diffExt ext1 ext2 =

723− let

724− different x y = ExtDifferent x y Bag.empty

725− in

624+extToStatus :: Extension -> Extension -> Status

625+extToStatus ext1 ext2 =

726626 case ext1 of

727627 Closed ->

728628 case ext2 of

729− Closed -> ExtSimilar

730− FlexOpen y -> different Nothing (Just y)

731− RigidOpen y -> different Nothing (Just y)

629+ Closed -> Similar

630+ FlexOpen _ -> Different Bag.empty

631+ RigidOpen _ -> Different Bag.empty

732632

733− FlexOpen x ->

633+ FlexOpen _ ->

734634 case ext2 of

735− Closed -> different (Just x) Nothing

736− FlexOpen _ -> ExtSimilar

737− RigidOpen _ -> ExtSimilar

635+ Closed -> Different Bag.empty

636+ FlexOpen _ -> Similar

637+ RigidOpen _ -> Similar

738638

739639 RigidOpen x ->

740640 case ext2 of

741− Closed -> different (Just x) Nothing

742− FlexOpen _ -> ExtSimilar

641+ Closed -> Different Bag.empty

642+ FlexOpen _ -> Similar

743643 RigidOpen y ->

744− if x == y then

745− ExtSimilar

746− else

747− ExtDifferent (Just x) (Just y) (Bag.one (BadRigidVar x (RigidVar y)))

748−

749−

750−

751−-- BAD OVERLAP

752−

753−

754−data BadOverlap =

755− BadOverlap

756− { _field :: N.Name

757− , _doc1 :: D.Doc

758− , _doc2 :: D.Doc

759− , _problemBag :: Bag.Bag Problem

760− }

761−

762−

763−findBadOverlaps :: L.Localizer -> Map.Map N.Name Diff -> [BadOverlap]

764−findBadOverlaps localizer overlaps =

765− Map.foldrWithKey (addBadOverlap localizer) [] overlaps

766−

767−

768−addBadOverlap :: L.Localizer -> N.Name -> Diff -> [BadOverlap] -> [BadOverlap]

769−addBadOverlap localizer field diff badOverlaps =

770− if isSimilar diff then

771− badOverlaps

772− else

773− let

774− (Pair aDoc bDoc problems) = diffToPair localizer RT.None diff

775− in

776− BadOverlap field aDoc bDoc problems : badOverlaps

644+ if x == y

645+ then Similar

646+ else Different $ Bag.one $ BadRigidVar x (RigidVar y)