git.iko.soy/elk
on 32ff950 help sign in
elk/compiler/src/Type/Error.hs
621 lines 17 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Error
4 ( Type(..)
5 , Super(..)
6 , Extension(..)
7 , iteratedDealias
8 , Localizer
9 , toDoc
10 , toDiffDocs
11 , Problem(..)
12 , isInt
13 , isFloat
14 , isString
15 , isChar
16 , isList
17 )
18 where
21import qualified Data.Map as Map
22import qualified Data.Maybe as Maybe
23import Data.Monoid ((<>))
25import qualified AST.Module.Name as ModuleName
26import qualified Data.Bag as Bag
27import qualified Elm.Name as N
28import qualified Reporting.Helpers as H
29import qualified Reporting.Render.Type as RT
33-- ERROR TYPES
36data Type
37 = Lambda Type Type [Type]
38 | Infinite
39 | Error
40 | FlexVar N.Name
41 | FlexSuper Super N.Name
42 | RigidVar N.Name
43 | RigidSuper Super N.Name
44 | Type ModuleName.Canonical N.Name [Type]
45 | Record (Map.Map N.Name Type) Extension
46 | Unit
47 | Tuple Type Type (Maybe Type)
48 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
51data Super
52 = Number
53 | Comparable
54 | Appendable
55 | CompAppend
58data Extension
59 = Closed
60 | FlexOpen N.Name
61 | RigidOpen N.Name
64iteratedDealias :: Type -> Type
65iteratedDealias tipe =
66 case tipe of
67 Alias _ _ _ realType ->
68 iteratedDealias realType
70 _ ->
71 tipe
75-- TO DOC
78type Localizer = Map.Map (ModuleName.Canonical, N.Name) String
81nameToDoc :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
82nameToDoc dict home@(ModuleName.Canonical _ moduleName) name =
83 case Map.lookup (home, name) dict of
84 Nothing ->
85 H.nameToDoc moduleName <> "." <> H.nameToDoc name
87 Just string ->
88 H.text string
91toDoc :: Localizer -> RT.Context -> Type -> H.Doc
92toDoc dict ctx tipe =
93 case tipe of
94 Lambda a b cs ->
95 RT.lambda ctx
96 (toDoc dict RT.Func a)
97 (toDoc dict RT.Func b)
98 (map (toDoc dict RT.Func) cs)
100 Infinite ->
101 "∞"
103 Error ->
104 "?"
106 FlexVar name ->
107 H.nameToDoc name
109 FlexSuper _ name ->
110 H.nameToDoc name
112 RigidVar name ->
113 H.nameToDoc name
115 RigidSuper _ name ->
116 H.nameToDoc name
118 Type home name args ->
119 RT.apply ctx
120 (nameToDoc dict home name)
121 (map (toDoc dict RT.App) args)
123 Record fields ext ->
124 let
125 entryToDocs (fieldName, fieldType) =
126 ( H.nameToDoc fieldName, toDoc dict RT.None fieldType )
128 fieldDocs =
129 map entryToDocs (Map.toList fields)
130 in
131 RT.record fieldDocs $
132 case ext of
133 Closed -> Nothing
134 FlexOpen x -> Just (H.nameToDoc x)
135 RigidOpen x -> Just (H.nameToDoc x)
137 Unit ->
138 "()"
140 Tuple a b maybeC ->
141 RT.tuple
142 (toDoc dict RT.None a)
143 (toDoc dict RT.None b)
144 (map (toDoc dict RT.None) (Maybe.maybeToList maybeC))
146 Alias home name args _ ->
147 RT.apply ctx
148 (nameToDoc dict home name)
149 (map (toDoc dict RT.App . snd) args)
153-- DIFF
156toDiffDocs :: Localizer -> Type -> Type -> (H.Doc, H.Doc, [Problem])
157toDiffDocs dict a b =
158 case diff dict RT.None a b of
159 Similar aDoc bDoc ->
160 (aDoc, bDoc, [])
162 Different aDoc bDoc problems ->
163 (aDoc, bDoc, Bag.toList problems)
166data Diff a
167 = Similar a a
168 | Different a a (Bag.Bag Problem)
171instance Functor Diff where
172 fmap func d =
173 case d of
174 Similar a b -> Similar (func a) (func b)
175 Different a b ps -> Different (func a) (func b) ps
178instance Applicative Diff where
179 pure a =
180 Similar a a
182 (<*>) dFunc dArg =
183 case dFunc of
184 Similar aFunc bFunc ->
185 case dArg of
186 Similar a b -> Similar (aFunc a) (bFunc b)
187 Different a b ps -> Different (aFunc a) (bFunc b) ps
189 Different aFunc bFunc ps ->
190 case dArg of
191 Similar a b -> Different (aFunc a) (bFunc b) ps
192 Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
196-- PROBLEMS
199data Problem
200 = FieldMismatch [N.Name] [N.Name]
201 | IntFloat
202 | StringFromInt
203 | StringFromFloat
204 | StringToInt
205 | StringToFloat
206 | AnythingToBool
207 | AnythingFromMaybe
208 | AnythingToList
209 | MissingArgs Int
210 | ReturnMismatch
211 | BadFlexSuper Super N.Name Type
212 | BadRigidVar N.Name Type
213 | BadRigidSuper Super N.Name Type
217-- COMPUTE DIFF
220diff :: Localizer -> RT.Context -> Type -> Type -> Diff H.Doc
221diff dict ctx tipe1 tipe2 =
222 case (tipe1, tipe2) of
223 (FlexVar x, FlexVar y) | x == y -> pure (H.nameToDoc x)
224 (FlexSuper _ x, FlexSuper _ y) | x == y -> pure (H.nameToDoc x)
225 (RigidVar x, RigidVar y) | x == y -> pure (H.nameToDoc x)
226 (RigidSuper _ x, RigidSuper _ y) | x == y -> pure (H.nameToDoc x)
228 (Infinite, Infinite) -> pure "∞"
229 (Error, Error) -> pure "?"
230 (Unit, Unit) -> pure "()"
232 (Tuple a b maybeC, Tuple x y maybeZ) ->
233 RT.tuple
234 <$> diff dict RT.None a x
235 <*> diff dict RT.None b y
236 <*>
237 case (maybeC, maybeZ) of
238 (Nothing, Nothing) -> pure []
239 (Just c , Nothing) -> Different [H.dullyellow (toDoc dict RT.None c)] [] Bag.empty
240 (Nothing, Just z ) -> Different [] [H.dullyellow (toDoc dict RT.None z)] Bag.empty
241 (Just c , Just z ) -> (:[]) <$> diff dict RT.None c z
243 (Record fields1 ext1, Record fields2 ext2) -> diffRecord dict fields1 ext1 fields2 ext2
245 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
246 RT.apply ctx (nameToDoc dict home1 name1) <$>
247 sequenceA (zipWith (diff dict RT.App) args1 args2)
249 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
250 RT.apply ctx (nameToDoc dict home1 name1) <$>
251 sequenceA (zipWith (diff dict RT.App) (map snd args1) (map snd args2))
253 (Alias _ _ _ alias1, other) -> diff dict ctx alias1 other
254 (other, Alias _ _ _ alias2) -> diff dict ctx other alias2
256 (Lambda a b cs, Lambda x y zs) -> diffLambda dict ctx (a:b:cs) (x:y:zs)
258 (FlexVar x, other) -> Similar (H.nameToDoc x) (toDoc dict ctx other)
259 (other, FlexVar x) -> Similar (toDoc dict ctx other) (H.nameToDoc x)
261 pair ->
262 case pair of
263 (Type home name [t1], t2) | isMaybe home name && isSimilar t1 t2 ->
264 Different (yellowApply dict ctx home name t1) (toDoc dict ctx t2) (Bag.one AnythingFromMaybe)
266 (t1, Type home name [t2]) | isList home name && isSimilar t1 t2 ->
267 Different (toDoc dict ctx t1) (yellowApply dict ctx home name t2) (Bag.one AnythingToList)
269 _ ->
270 let
271 doc1 = H.dullyellow (toDoc dict ctx tipe1)
272 doc2 = H.dullyellow (toDoc dict ctx tipe2)
273 in
274 Different doc1 doc2 $
275 case pair of
276 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
277 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
278 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
279 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
280 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
281 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
283 (Type home1 name1 [], Type home2 name2 [])
284 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
285 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
286 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
287 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
288 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
289 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
290 | isBool home2 name2 -> Bag.one AnythingToBool
292 (_, _) -> Bag.empty
295isBool :: ModuleName.Canonical -> N.Name -> Bool
296isBool home name =
297 home == ModuleName.basics && name == N.bool
300isInt :: ModuleName.Canonical -> N.Name -> Bool
301isInt home name =
302 home == ModuleName.basics && name == N.int
305isFloat :: ModuleName.Canonical -> N.Name -> Bool
306isFloat home name =
307 home == ModuleName.basics && name == N.float
310isString :: ModuleName.Canonical -> N.Name -> Bool
311isString home name =
312 home == ModuleName.string && name == N.string
315isChar :: ModuleName.Canonical -> N.Name -> Bool
316isChar home name =
317 home == ModuleName.char && name == N.char
320isMaybe :: ModuleName.Canonical -> N.Name -> Bool
321isMaybe home name =
322 home == ModuleName.maybe && name == N.maybe
325isList :: ModuleName.Canonical -> N.Name -> Bool
326isList home name =
327 home == ModuleName.list && name == N.list
330isSimilar :: Type -> Type -> Bool
331isSimilar tipe1 tipe2 =
332 case diff Map.empty RT.None tipe1 tipe2 of
333 Similar _ _ -> True
334 Different _ _ _ -> False
337yellowApply :: Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> H.Doc
338yellowApply dict ctx home name tipe =
339 RT.apply ctx
340 (H.dullyellow (nameToDoc dict home name))
341 [toDoc dict RT.App tipe]
345-- DIFF LAMBDAS
348--
349-- INVARIANT: length types1 >= 2 && length types2 >= 2
350--
351diffLambda :: Localizer -> RT.Context -> [Type] -> [Type] -> Diff H.Doc
352diffLambda dict ctx types1 types2 =
353 let
354 (result1:revArgs1) = reverse types1
355 (result2:revArgs2) = reverse types2
357 numArgs1 = length revArgs1
358 numArgs2 = length revArgs2
360 resultDiff = diff dict RT.Func result1 result2
361 in
362 case resultDiff of
363 Similar resultDoc1 resultDoc2 ->
364 if numArgs1 == numArgs2 then
365 (\resultDoc revArgsDoc ->
366 let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
367 RT.lambda ctx x y zs
368 )
369 <$> resultDiff
370 <*> sequenceA (zipWith (diff dict RT.Func) revArgs1 revArgs2)
372 else if numArgs1 < numArgs2 then
373 diffArgMismatch dict ctx revArgs1 resultDoc1 revArgs2 resultDoc2
375 else
376 diffArgMismatch dict ctx revArgs2 resultDoc2 revArgs1 resultDoc1
378 Different resultDoc1 resultDoc2 problems ->
379 let
380 (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc dict RT.Func) revArgs1)
381 (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc dict RT.Func) revArgs2)
382 in
383 Different
384 (RT.lambda ctx x1 y1 zs1)
385 (RT.lambda ctx x2 y2 zs2)
386 (Bag.append (Bag.one ReturnMismatch) problems)
389--
390-- INVARIANT: length shortRevArgs >= 2 && length longRevArgs >= 2
391--
392diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
393diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
394 case toGreedyMatch dict shortRevArgs longRevArgs of
395 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
396 let
397 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
398 (x:y:zs) = reverse (longResult:longRevArgDocs)
399 in
400 Different
401 (RT.lambda ctx a b cs)
402 (RT.lambda ctx x y zs)
403 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
405 Nothing ->
406 case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) of
407 Just (GreedyMatch shortArgDocs longArgDocs) ->
408 let
409 (a:b:cs) = shortArgDocs ++ [shortResult]
410 (x:y:zs) = longArgDocs ++ [longResult ]
411 in
412 Different
413 (RT.lambda ctx a b cs)
414 (RT.lambda ctx x y zs)
415 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
417 Nothing ->
418 let
419 toYellowDoc tipe =
420 H.dullyellow (toDoc dict RT.Func tipe)
422 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
423 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
424 in
425 Different
426 (RT.lambda ctx a b cs)
427 (RT.lambda ctx x y zs)
428 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
432-- GREEDY ARG MATCHER
435data GreedyMatch =
436 GreedyMatch [H.Doc] [H.Doc]
439--
440-- INVARIANT: length shorterArgs < length longerArgs
441--
442toGreedyMatch :: Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
443toGreedyMatch dict shorterArgs longerArgs =
444 toGreedyMatchHelp dict shorterArgs longerArgs (GreedyMatch [] [])
447toGreedyMatchHelp :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
448toGreedyMatchHelp dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
449 let
450 toYellowDoc tipe =
451 H.dullyellow (toDoc dict RT.Func tipe)
452 in
453 case (shorterArgs, longerArgs) of
454 (x:xs, y:ys) ->
455 case diff dict RT.Func x y of
456 Similar a b ->
457 toGreedyMatchHelp dict xs ys $
458 GreedyMatch (a:shorterDocs) (b:longerDocs)
460 Different _ _ _ ->
461 toGreedyMatchHelp dict shorterArgs ys $
462 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
464 ([], []) ->
465 Just match
467 ([], _:_) ->
468 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
470 (_:_, []) ->
471 Nothing
475-- RECORD DIFFS
478diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
479diffRecord dict fields1 ext1 fields2 ext2 =
480 let
481 only1 = Map.keys (Map.difference fields1 fields2)
482 only2 = Map.keys (Map.difference fields2 fields1)
483 in
484 if null only1 && null only2 then
485 case findBadOverlaps dict fields1 fields2 of
486 [] ->
487 case diffExt ext1 ext2 of
488 Similar _ _ ->
489 Similar (toBoringRecord fields1 ext1) (toBoringRecord fields2 ext2)
491 Different dExt1 dExt2 problems ->
492 Different (RT.record [] dExt1) (RT.record [] dExt2) problems
494 overlaps@(bad:bads) ->
495 if length overlaps < Map.size fields1 then
496 Different
497 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
498 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
499 (foldr Bag.append Bag.empty (map _problems overlaps))
500 else
501 Different
502 (toOverlapRecord _doc1 bad bads ext1)
503 (toOverlapRecord _doc2 bad bads ext2)
504 (foldr Bag.append Bag.empty (map _problems overlaps))
506 else
507 Different
508 (toMissingDoc fields1 only1 ext1)
509 (toMissingDoc fields2 only2 ext2)
510 (Bag.one (FieldMismatch only1 only2))
513toOverlapDoc :: (BadOverlap -> H.Doc) -> BadOverlap -> (H.Doc, H.Doc)
514toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
515 (H.nameToDoc field, getDoc overlap)
518toOverlapRecord :: (BadOverlap -> H.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> H.Doc
519toOverlapRecord getDoc bad bads ext =
520 let go = toOverlapDoc getDoc in
521 case ext of
522 Closed -> RT.record (map go (bad:bads)) Nothing
523 FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)
524 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
527toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> H.Doc
528toMissingDoc allFields uniqueFields ext =
529 case map emphasizeFieldName uniqueFields of
530 [] ->
531 toBoringRecord allFields ext
533 doc:docs ->
534 if length uniqueFields < Map.size allFields then
535 RT.recordSnippet doc docs
536 else
537 case ext of
538 Closed -> RT.record (doc:docs) Nothing
539 FlexOpen _ -> RT.recordSnippet doc docs
540 RigidOpen _ -> RT.recordSnippet doc docs
543emphasizeFieldName :: N.Name -> (H.Doc, H.Doc)
544emphasizeFieldName field =
545 ( H.dullyellow (H.nameToDoc field), "..." )
548toBoringRecord :: Map.Map N.Name t -> Extension -> H.Doc
549toBoringRecord fields ext =
550 case ext of
551 Closed -> if Map.null fields then "{}" else "{ ... }"
552 FlexOpen _ -> "{ ... }"
553 RigidOpen _ -> "{ ... }"
557-- DIFF RECORD EXTENSION
560diffExt :: Extension -> Extension -> Diff (Maybe H.Doc)
561diffExt ext1 ext2 =
562 let
563 normal = Just . H.nameToDoc
564 yellow = Just . H.dullyellow . H.nameToDoc
566 different x y = Different x y Bag.empty
567 in
568 case ext1 of
569 Closed ->
570 case ext2 of
571 Closed -> Similar Nothing Nothing
572 FlexOpen y -> different Nothing (yellow y)
573 RigidOpen y -> different Nothing (yellow y)
575 FlexOpen x ->
576 case ext2 of
577 Closed -> different (yellow x) Nothing
578 FlexOpen y -> Similar (normal x) (normal y)
579 RigidOpen y -> Similar (normal x) (normal y)
581 RigidOpen x ->
582 case ext2 of
583 Closed -> different (yellow x) Nothing
584 FlexOpen y -> Similar (normal x) (normal y)
585 RigidOpen y ->
586 if x == y then
587 Similar (normal x) (normal y)
588 else
589 Different (yellow x) (yellow y) (Bag.one (BadRigidVar x (RigidVar y)))
593-- BAD OVERLAP
596data BadOverlap =
597 BadOverlap
598 { _field :: N.Name
599 , _doc1 :: H.Doc
600 , _doc2 :: H.Doc
601 , _problems :: Bag.Bag Problem
602 }
605findBadOverlaps :: Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
606findBadOverlaps dict fields1 fields2 =
607 findBadOverlapsHelp [] $ Map.toList $
608 Map.intersectionWith (diff dict RT.None) fields1 fields2
611findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff H.Doc)] -> [BadOverlap]
612findBadOverlapsHelp badOverlaps fieldPairs =
613 case fieldPairs of
614 [] ->
615 badOverlaps
617 (_, Similar _ _) : otherFieldPairs ->
618 findBadOverlapsHelp badOverlaps otherFieldPairs
620 (field, Different aDoc bDoc problems) : otherFieldPairs ->
621 findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs