1{-# OPTIONS_GHC -Wall #-} 2{-# LANGUAGE OverloadedStrings #-} 3module Type.Error 4 ( Type(..) 5 , Super(..) 6 , Extension(..) 7 , iteratedDealias 8 , toDoc 9 , Problem(..) 10 , Direction(..) 11 , toComparison 12 , isInt 13 , isFloat 14 , isString 15 , isChar 16 , isList 17 ) 18 where 19 20 21import qualified Data.Map as Map 22import qualified Data.Maybe as Maybe 23import Data.Monoid ((<>)) 24import qualified Data.Name as Name 25 26import qualified Data.Bag as Bag 27import qualified Elm.ModuleName as ModuleName 28import qualified Reporting.Doc as D 29import qualified Reporting.Render.Type as RT 30import qualified Reporting.Render.Type.Localizer as L 31 32 33 34-- ERROR TYPES 35 36 37data Type 38 = Lambda Type Type [Type] 39 | Infinite 40 | Error 41 | FlexVar Name.Name 42 | FlexSuper Super Name.Name 43 | RigidVar Name.Name 44 | RigidSuper Super Name.Name 45 | Type ModuleName.Canonical Name.Name [Type] 46 | Record (Map.Map Name.Name Type) Extension 47 | Unit 48 | Tuple Type Type (Maybe Type) 49 | Alias ModuleName.Canonical Name.Name [(Name.Name, Type)] Type 50 51 52data Super 53 = Number 54 | Comparable 55 | Appendable 56 | CompAppend 57 deriving (Eq) 58 59 60data Extension 61 = Closed 62 | FlexOpen Name.Name 63 | RigidOpen Name.Name 64 65 66iteratedDealias :: Type -> Type 67iteratedDealias tipe = 68 case tipe of 69 Alias _ _ _ real -> 70 iteratedDealias real 71 72 _ -> 73 tipe 74 75 76 77-- TO DOC 78 79 80toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc 81toDoc localizer ctx tipe = 82 case tipe of 83 Lambda a b cs -> 84 RT.lambda ctx 85 (toDoc localizer RT.Func a) 86 (toDoc localizer RT.Func b) 87 (map (toDoc localizer RT.Func) cs) 88 89 Infinite -> 90 "∞" 91 92 Error -> 93 "?" 94 95 FlexVar name -> 96 D.fromName name 97 98 FlexSuper _ name -> 99 D.fromName name 100 101 RigidVar name -> 102 D.fromName name 103 104 RigidSuper _ name -> 105 D.fromName name 106 107 Type home name args -> 108 RT.apply ctx 109 (L.toDoc localizer home name) 110 (map (toDoc localizer RT.App) args) 111 112 Record fields ext -> 113 RT.record (fieldsToDocs localizer fields) (extToDoc ext) 114 115 Unit -> 116 "()" 117 118 Tuple a b maybeC -> 119 RT.tuple 120 (toDoc localizer RT.None a) 121 (toDoc localizer RT.None b) 122 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC)) 123 124 Alias home name args _ -> 125 aliasToDoc localizer ctx home name args 126 127 128aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Type)] -> D.Doc 129aliasToDoc localizer ctx home name args = 130 RT.apply ctx 131 (L.toDoc localizer home name) 132 (map (toDoc localizer RT.App . snd) args) 133 134 135fieldsToDocs :: L.Localizer -> Map.Map Name.Name Type -> [(D.Doc, D.Doc)] 136fieldsToDocs localizer fields = 137 Map.foldrWithKey (addField localizer) [] fields 138 139 140addField :: L.Localizer -> Name.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)] 141addField localizer fieldName fieldType docs = 142 let 143 f = D.fromName fieldName 144 t = toDoc localizer RT.None fieldType 145 in 146 (f,t) : docs 147 148 149extToDoc :: Extension -> Maybe D.Doc 150extToDoc ext = 151 case ext of 152 Closed -> Nothing 153 FlexOpen x -> Just (D.fromName x) 154 RigidOpen x -> Just (D.fromName x) 155 156 157 158-- DIFF 159 160 161data Diff a = 162 Diff a a Status 163 164 165data Status 166 = Similar 167 | Different (Bag.Bag Problem) 168 169 170data Problem 171 = IntFloat 172 | StringFromInt 173 | StringFromFloat 174 | StringToInt 175 | StringToFloat 176 | AnythingToBool 177 | AnythingFromMaybe 178 | ArityMismatch Int Int 179 | BadFlexSuper Direction Super Name.Name Type 180 | BadRigidVar Name.Name Type 181 | BadRigidSuper Super Name.Name Type 182 | FieldTypo Name.Name [Name.Name] 183 | FieldsMissing [Name.Name] 184 185 186data Direction = Have | Need 187 188 189instance Functor Diff where 190 fmap func (Diff a b status) = 191 Diff (func a) (func b) status 192 193 194instance Applicative Diff where 195 pure a = 196 Diff a a Similar 197 198 (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) = 199 Diff (aFunc aArg) (bFunc bArg) (merge status1 status2) 200 201 202merge :: Status -> Status -> Status 203merge status1 status2 = 204 case status1 of 205 Similar -> 206 status2 207 208 Different problems1 -> 209 case status2 of 210 Similar -> 211 status1 212 213 Different problems2 -> 214 Different (Bag.append problems1 problems2) 215 216 217 218-- COMPARISON 219 220 221toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem]) 222toComparison localizer tipe1 tipe2 = 223 case toDiff localizer RT.None tipe1 tipe2 of 224 Diff doc1 doc2 Similar -> 225 (doc1, doc2, []) 226 227 Diff doc1 doc2 (Different problems) -> 228 (doc1, doc2, Bag.toList problems) 229 230 231toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc 232toDiff localizer ctx tipe1 tipe2 = 233 case (tipe1, tipe2) of 234 (Unit , Unit ) -> same localizer ctx tipe1 235 (Error , Error ) -> same localizer ctx tipe1 236 (Infinite, Infinite) -> same localizer ctx tipe1 237 238 (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1 239 (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1 240 (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1 241 (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1 242 243 (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2 244 (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2 245 246 (FlexSuper s _, t ) | isSuper s t -> similar localizer ctx tipe1 tipe2 247 (t , FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2 248 249 (Lambda a b cs, Lambda x y zs) -> 250 if length cs == length zs then 251 RT.lambda ctx 252 <$> toDiff localizer RT.Func a x 253 <*> toDiff localizer RT.Func b y 254 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs) 255 else 256 let f = toDoc localizer RT.Func in 257 different 258 (D.dullyellow (RT.lambda ctx (f a) (f b) (map f cs))) 259 (D.dullyellow (RT.lambda ctx (f x) (f y) (map f zs))) 260 (Bag.one (ArityMismatch (2 + length cs) (2 + length zs))) 261 262 (Tuple a b Nothing, Tuple x y Nothing) -> 263 RT.tuple 264 <$> toDiff localizer RT.None a x 265 <*> toDiff localizer RT.None b y 266 <*> pure [] 267 268 (Tuple a b (Just c), Tuple x y (Just z)) -> 269 RT.tuple 270 <$> toDiff localizer RT.None a x 271 <*> toDiff localizer RT.None b y 272 <*> ((:[]) <$> toDiff localizer RT.None c z) 273 274 (Record fields1 ext1, Record fields2 ext2) -> 275 diffRecord localizer fields1 ext1 fields2 ext2 276 277 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 -> 278 RT.apply ctx (L.toDoc localizer home1 name1) 279 <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2) 280 281 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 -> 282 RT.apply ctx (L.toDoc localizer home1 name1) 283 <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2)) 284 285 -- start trying to find specific problems 286 287 (Type home1 name1 args1, Type home2 name2 args2) | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 -> 288 different 289 (nameClashToDoc ctx localizer home1 name1 args1) 290 (nameClashToDoc ctx localizer home2 name2 args2) 291 Bag.empty 292 293 (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) -> 294 different 295 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1]) 296 (toDoc localizer ctx t2) 297 (Bag.one AnythingFromMaybe) 298 299 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) -> 300 different 301 (toDoc localizer ctx t1) 302 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2]) 303 Bag.empty 304 305 (Alias home1 name1 args1 t1, t2) -> 306 case diffAliasedRecord localizer t1 t2 of 307 Just (Diff _ doc2 status) -> 308 Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status 309 310 Nothing -> 311 case t2 of 312 Type home2 name2 args2 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 -> 313 different 314 (nameClashToDoc ctx localizer home1 name1 (map snd args1)) 315 (nameClashToDoc ctx localizer home2 name2 args2) 316 Bag.empty 317 318 _ -> 319 different 320 (D.dullyellow (toDoc localizer ctx tipe1)) 321 (D.dullyellow (toDoc localizer ctx tipe2)) 322 Bag.empty 323 324 (t1, Alias home2 name2 args2 t2) -> 325 case diffAliasedRecord localizer t1 t2 of 326 Just (Diff doc1 _ status) -> 327 Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status 328 329 Nothing -> 330 case t1 of 331 Type home1 name1 args1 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 -> 332 different 333 (nameClashToDoc ctx localizer home1 name1 args1) 334 (nameClashToDoc ctx localizer home2 name2 (map snd args2)) 335 Bag.empty 336 337 _ -> 338 different 339 (D.dullyellow (toDoc localizer ctx tipe1)) 340 (D.dullyellow (toDoc localizer ctx tipe2)) 341 Bag.empty 342 343 pair -> 344 let 345 doc1 = D.dullyellow (toDoc localizer ctx tipe1) 346 doc2 = D.dullyellow (toDoc localizer ctx tipe2) 347 in 348 different doc1 doc2 $ 349 case pair of 350 (RigidVar x, other) -> Bag.one $ BadRigidVar x other 351 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper Have s x other 352 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other 353 (other, RigidVar x) -> Bag.one $ BadRigidVar x other 354 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper Need s x other 355 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other 356 357 (Type home1 name1 [], Type home2 name2 []) 358 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat 359 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat 360 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt 361 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat 362 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt 363 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat 364 | isBool home2 name2 -> Bag.one AnythingToBool 365 366 (_, _) -> 367 Bag.empty 368 369 370 371-- DIFF HELPERS 372 373 374same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc 375same localizer ctx tipe = 376 let 377 doc = toDoc localizer ctx tipe 378 in 379 Diff doc doc Similar 380 381 382similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc 383similar localizer ctx t1 t2 = 384 Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar 385 386 387different :: a -> a -> Bag.Bag Problem -> Diff a 388different a b problems = 389 Diff a b (Different problems) 390 391 392isSimilar :: Diff a -> Bool 393isSimilar (Diff _ _ status) = 394 case status of 395 Similar -> True 396 Different _ -> False 397 398 399 400-- IS TYPE? 401 402 403isBool :: ModuleName.Canonical -> Name.Name -> Bool 404isBool home name = 405 home == ModuleName.basics && name == Name.bool 406 407 408isInt :: ModuleName.Canonical -> Name.Name -> Bool 409isInt home name = 410 home == ModuleName.basics && name == Name.int 411 412 413isFloat :: ModuleName.Canonical -> Name.Name -> Bool 414isFloat home name = 415 home == ModuleName.basics && name == Name.float 416 417 418isString :: ModuleName.Canonical -> Name.Name -> Bool 419isString home name = 420 home == ModuleName.string && name == Name.string 421 422 423isChar :: ModuleName.Canonical -> Name.Name -> Bool 424isChar home name = 425 home == ModuleName.char && name == Name.char 426 427 428isMaybe :: ModuleName.Canonical -> Name.Name -> Bool 429isMaybe home name = 430 home == ModuleName.maybe && name == Name.maybe 431 432 433isList :: ModuleName.Canonical -> Name.Name -> Bool 434isList home name = 435 home == ModuleName.list && name == Name.list 436 437 438 439-- IS SUPER? 440 441 442isSuper :: Super -> Type -> Bool 443isSuper super tipe = 444 case iteratedDealias tipe of 445 Type h n args -> 446 case super of 447 Number -> isInt h n || isFloat h n 448 Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args) 449 Appendable -> isString h n || isList h n 450 CompAppend -> isString h n || isList h n && isSuper Comparable (head args) 451 452 Tuple a b maybeC -> 453 case super of 454 Number -> False 455 Comparable -> isSuper super a && isSuper super b && maybe True (isSuper super) maybeC 456 Appendable -> False 457 CompAppend -> False 458 459 _ -> 460 False 461 462 463 464-- NAME CLASH 465 466 467nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> Name.Name -> [Type] -> D.Doc 468nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args = 469 RT.apply ctx 470 (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name)) 471 (map (toDoc localizer RT.App) args) 472 473 474 475-- DIFF ALIASED RECORD 476 477 478diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc) 479diffAliasedRecord localizer t1 t2 = 480 case (iteratedDealias t1, iteratedDealias t2) of 481 (Record fields1 ext1, Record fields2 ext2) -> 482 Just (diffRecord localizer fields1 ext1 fields2 ext2) 483 484 _ -> 485 Nothing 486 487 488 489-- RECORD DIFFS 490 491 492diffRecord :: L.Localizer -> Map.Map Name.Name Type -> Extension -> Map.Map Name.Name Type -> Extension -> Diff D.Doc 493diffRecord localizer fields1 ext1 fields2 ext2 = 494 let 495 toUnknownDocs field tipe = 496 ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe ) 497 498 toOverlapDocs field t1 t2 = 499 (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2 500 501 left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2) 502 both = Map.intersectionWithKey toOverlapDocs fields1 fields2 503 right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1) 504 505 fieldsDiff = 506 Map.elems <$> 507 if Map.null left && Map.null right then 508 sequenceA both 509 else 510 Map.union 511 <$> sequenceA both 512 <*> Diff left right (Different Bag.empty) 513 514 (Diff doc1 doc2 status) = 515 RT.record 516 <$> fieldsDiff 517 <*> extToDiff ext1 ext2 518 in 519 Diff doc1 doc2 $ merge status $ 520 case (hasFixedFields ext1, hasFixedFields ext2) of 521 (True, True) -> 522 case Map.lookupMin left of 523 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2) 524 Nothing -> 525 if Map.null right 526 then Similar 527 else Different $ Bag.one $ FieldsMissing (Map.keys right) 528 529 (False, True) -> 530 case Map.lookupMin left of 531 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2) 532 Nothing -> Similar 533 534 (True, False) -> 535 case Map.lookupMin right of 536 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1) 537 Nothing -> Similar 538 539 (False, False) -> 540 Similar 541 542 543hasFixedFields :: Extension -> Bool 544hasFixedFields ext = 545 case ext of 546 Closed -> True 547 FlexOpen _ -> False 548 RigidOpen _ -> True 549 550 551 552-- DIFF RECORD EXTENSION 553 554 555extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc) 556extToDiff ext1 ext2 = 557 let 558 status = extToStatus ext1 ext2 559 extDoc1 = extToDoc ext1 560 extDoc2 = extToDoc ext2 561 in 562 case status of 563 Similar -> 564 Diff extDoc1 extDoc2 status 565 566 Different _ -> 567 Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status 568 569 570extToStatus :: Extension -> Extension -> Status 571extToStatus ext1 ext2 = 572 case ext1 of 573 Closed -> 574 case ext2 of 575 Closed -> Similar 576 FlexOpen _ -> Similar 577 RigidOpen _ -> Different Bag.empty 578 579 FlexOpen _ -> 580 Similar 581 582 RigidOpen x -> 583 case ext2 of 584 Closed -> Different Bag.empty 585 FlexOpen _ -> Similar 586 RigidOpen y -> 587 if x == y 588 then Similar 589 else Different $ Bag.one $ BadRigidVar x (RigidVar y) 590