git.iko.soy/elk
on 117100e help sign in
elk/compiler/src/Type/Error.hs
612 lines 17 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Error
4 ( Type(..)
5 , Super(..)
6 , Extension(..)
7 , iteratedDealias
8 , toDoc
9 , toDiffDocs
10 , Problem(..)
11 , isInt
12 , isFloat
13 , isString
14 , isChar
15 , isList
16 )
17 where
20import qualified Data.Map as Map
21import qualified Data.Maybe as Maybe
23import qualified AST.Module.Name as ModuleName
24import qualified Data.Bag as Bag
25import qualified Elm.Name as N
26import qualified Reporting.Doc as D
27import qualified Reporting.Render.Type as RT
28import qualified Reporting.Render.Type.Localizer as L
32-- ERROR TYPES
35data Type
36 = Lambda Type Type [Type]
37 | Infinite
38 | Error
39 | FlexVar N.Name
40 | FlexSuper Super N.Name
41 | RigidVar N.Name
42 | RigidSuper Super N.Name
43 | Type ModuleName.Canonical N.Name [Type]
44 | Record (Map.Map N.Name Type) Extension
45 | Unit
46 | Tuple Type Type (Maybe Type)
47 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
50data Super
51 = Number
52 | Comparable
53 | Appendable
54 | CompAppend
57data Extension
58 = Closed
59 | FlexOpen N.Name
60 | RigidOpen N.Name
63iteratedDealias :: Type -> Type
64iteratedDealias tipe =
65 case tipe of
66 Alias _ _ _ realType ->
67 iteratedDealias realType
69 _ ->
70 tipe
74-- TO DOC
77nameToDoc :: L.Localizer -> ModuleName.Canonical -> N.Name -> D.Doc
78nameToDoc localizer (ModuleName.Canonical _ home) name =
79 L.toDoc localizer home name
82toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
83toDoc localizer ctx tipe =
84 case tipe of
85 Lambda a b cs ->
86 RT.lambda ctx
87 (toDoc localizer RT.Func a)
88 (toDoc localizer RT.Func b)
89 (map (toDoc localizer RT.Func) cs)
91 Infinite ->
92 "∞"
94 Error ->
95 "?"
97 FlexVar name ->
98 D.fromName name
100 FlexSuper _ name ->
101 D.fromName name
103 RigidVar name ->
104 D.fromName name
106 RigidSuper _ name ->
107 D.fromName name
109 Type home name args ->
110 RT.apply ctx
111 (nameToDoc localizer home name)
112 (map (toDoc localizer RT.App) args)
114 Record fields ext ->
115 let
116 entryToDocs (fieldName, fieldType) =
117 ( D.fromName fieldName, toDoc localizer RT.None fieldType )
119 fieldDocs =
120 map entryToDocs (Map.toList fields)
121 in
122 RT.record fieldDocs $
123 case ext of
124 Closed -> Nothing
125 FlexOpen x -> Just (D.fromName x)
126 RigidOpen x -> Just (D.fromName x)
128 Unit ->
129 "()"
131 Tuple a b maybeC ->
132 RT.tuple
133 (toDoc localizer RT.None a)
134 (toDoc localizer RT.None b)
135 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
137 Alias home name args _ ->
138 RT.apply ctx
139 (nameToDoc localizer home name)
140 (map (toDoc localizer RT.App . snd) args)
144-- DIFF
147toDiffDocs :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
148toDiffDocs localizer a b =
149 case diff localizer RT.None a b of
150 Similar aDoc bDoc ->
151 (aDoc, bDoc, [])
153 Different aDoc bDoc problems ->
154 (aDoc, bDoc, Bag.toList problems)
157data Diff a
158 = Similar a a
159 | Different a a (Bag.Bag Problem)
162instance Functor Diff where
163 fmap func d =
164 case d of
165 Similar a b -> Similar (func a) (func b)
166 Different a b ps -> Different (func a) (func b) ps
169instance Applicative Diff where
170 pure a =
171 Similar a a
173 (<*>) dFunc dArg =
174 case dFunc of
175 Similar aFunc bFunc ->
176 case dArg of
177 Similar a b -> Similar (aFunc a) (bFunc b)
178 Different a b ps -> Different (aFunc a) (bFunc b) ps
180 Different aFunc bFunc ps ->
181 case dArg of
182 Similar a b -> Different (aFunc a) (bFunc b) ps
183 Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
187-- PROBLEMS
190data Problem
191 = FieldMismatch [N.Name] [N.Name]
192 | IntFloat
193 | StringFromInt
194 | StringFromFloat
195 | StringToInt
196 | StringToFloat
197 | AnythingToBool
198 | AnythingFromMaybe
199 | AnythingToList
200 | MissingArgs Int
201 | ReturnMismatch
202 | BadFlexSuper Super N.Name Type
203 | BadRigidVar N.Name Type
204 | BadRigidSuper Super N.Name Type
208-- COMPUTE DIFF
211diff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
212diff localizer ctx tipe1 tipe2 =
213 case (tipe1, tipe2) of
214 (FlexVar x, FlexVar y) | x == y -> pure (D.fromName x)
215 (FlexSuper _ x, FlexSuper _ y) | x == y -> pure (D.fromName x)
216 (RigidVar x, RigidVar y) | x == y -> pure (D.fromName x)
217 (RigidSuper _ x, RigidSuper _ y) | x == y -> pure (D.fromName x)
219 (Infinite, Infinite) -> pure "∞"
220 (Error, Error) -> pure "?"
221 (Unit, Unit) -> pure "()"
223 (Tuple a b maybeC, Tuple x y maybeZ) ->
224 RT.tuple
225 <$> diff localizer RT.None a x
226 <*> diff localizer RT.None b y
227 <*>
228 case (maybeC, maybeZ) of
229 (Nothing, Nothing) -> pure []
230 (Just c , Nothing) -> Different [D.dullyellow (toDoc localizer RT.None c)] [] Bag.empty
231 (Nothing, Just z ) -> Different [] [D.dullyellow (toDoc localizer RT.None z)] Bag.empty
232 (Just c , Just z ) -> (:[]) <$> diff localizer RT.None c z
234 (Record fields1 ext1, Record fields2 ext2) -> diffRecord localizer fields1 ext1 fields2 ext2
236 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
237 RT.apply ctx (nameToDoc localizer home1 name1) <$>
238 sequenceA (zipWith (diff localizer RT.App) args1 args2)
240 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
241 RT.apply ctx (nameToDoc localizer home1 name1) <$>
242 sequenceA (zipWith (diff localizer RT.App) (map snd args1) (map snd args2))
244 (Alias _ _ _ alias1, other) -> diff localizer ctx alias1 other
245 (other, Alias _ _ _ alias2) -> diff localizer ctx other alias2
247 (Lambda a b cs, Lambda x y zs) -> diffLambda localizer ctx (a:b:cs) (x:y:zs)
249 (FlexVar x, other) -> Similar (D.fromName x) (toDoc localizer ctx other)
250 (other, FlexVar x) -> Similar (toDoc localizer ctx other) (D.fromName x)
252 pair ->
253 case pair of
254 (Type home name [t1], t2) | isMaybe home name && isSimilar t1 t2 ->
255 Different (yellowApply localizer ctx home name t1) (toDoc localizer ctx t2) (Bag.one AnythingFromMaybe)
257 (t1, Type home name [t2]) | isList home name && isSimilar t1 t2 ->
258 Different (toDoc localizer ctx t1) (yellowApply localizer ctx home name t2) (Bag.one AnythingToList)
260 _ ->
261 let
262 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
263 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
264 in
265 Different doc1 doc2 $
266 case pair of
267 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
268 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
269 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
270 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
271 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
272 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
274 (Type home1 name1 [], Type home2 name2 [])
275 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
276 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
277 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
278 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
279 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
280 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
281 | isBool home2 name2 -> Bag.one AnythingToBool
283 (_, _) -> Bag.empty
286isBool :: ModuleName.Canonical -> N.Name -> Bool
287isBool home name =
288 home == ModuleName.basics && name == N.bool
291isInt :: ModuleName.Canonical -> N.Name -> Bool
292isInt home name =
293 home == ModuleName.basics && name == N.int
296isFloat :: ModuleName.Canonical -> N.Name -> Bool
297isFloat home name =
298 home == ModuleName.basics && name == N.float
301isString :: ModuleName.Canonical -> N.Name -> Bool
302isString home name =
303 home == ModuleName.string && name == N.string
306isChar :: ModuleName.Canonical -> N.Name -> Bool
307isChar home name =
308 home == ModuleName.char && name == N.char
311isMaybe :: ModuleName.Canonical -> N.Name -> Bool
312isMaybe home name =
313 home == ModuleName.maybe && name == N.maybe
316isList :: ModuleName.Canonical -> N.Name -> Bool
317isList home name =
318 home == ModuleName.list && name == N.list
321isSimilar :: Type -> Type -> Bool
322isSimilar tipe1 tipe2 =
323 case diff L.empty RT.None tipe1 tipe2 of
324 Similar _ _ -> True
325 Different _ _ _ -> False
328yellowApply :: L.Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> D.Doc
329yellowApply localizer ctx home name tipe =
330 RT.apply ctx
331 (D.dullyellow (nameToDoc localizer home name))
332 [toDoc localizer RT.App tipe]
336-- DIFF LAMBDAS
339--
340-- INVARIANT: length types1 >= 2 && length types2 >= 2
341--
342diffLambda :: L.Localizer -> RT.Context -> [Type] -> [Type] -> Diff D.Doc
343diffLambda localizer ctx types1 types2 =
344 let
345 (result1:revArgs1) = reverse types1
346 (result2:revArgs2) = reverse types2
348 numArgs1 = length revArgs1
349 numArgs2 = length revArgs2
351 resultDiff = diff localizer RT.Func result1 result2
352 in
353 case resultDiff of
354 Similar resultDoc1 resultDoc2 ->
355 if numArgs1 == numArgs2 then
356 (\resultDoc revArgsDoc ->
357 let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
358 RT.lambda ctx x y zs
359 )
360 <$> resultDiff
361 <*> sequenceA (zipWith (diff localizer RT.Func) revArgs1 revArgs2)
363 else if numArgs1 < numArgs2 then
364 diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2
366 else
367 diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1
369 Different resultDoc1 resultDoc2 problems ->
370 let
371 (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)
372 (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)
373 in
374 Different
375 (RT.lambda ctx x1 y1 zs1)
376 (RT.lambda ctx x2 y2 zs2)
377 (Bag.append (Bag.one ReturnMismatch) problems)
380--
381-- INVARIANT: length shortRevArgs >= 2 && length longRevArgs >= 2
382--
383diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc
384diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
385 case toGreedyMatch localizer shortRevArgs longRevArgs of
386 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
387 let
388 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
389 (x:y:zs) = reverse (longResult:longRevArgDocs)
390 in
391 Different
392 (RT.lambda ctx a b cs)
393 (RT.lambda ctx x y zs)
394 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
396 Nothing ->
397 case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of
398 Just (GreedyMatch shortArgDocs longArgDocs) ->
399 let
400 (a:b:cs) = shortArgDocs ++ [shortResult]
401 (x:y:zs) = longArgDocs ++ [longResult ]
402 in
403 Different
404 (RT.lambda ctx a b cs)
405 (RT.lambda ctx x y zs)
406 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
408 Nothing ->
409 let
410 toYellowDoc tipe =
411 D.dullyellow (toDoc localizer RT.Func tipe)
413 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
414 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
415 in
416 Different
417 (RT.lambda ctx a b cs)
418 (RT.lambda ctx x y zs)
419 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
423-- GREEDY ARG MATCHER
426data GreedyMatch =
427 GreedyMatch [D.Doc] [D.Doc]
430--
431-- INVARIANT: length shorterArgs < length longerArgs
432--
433toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
434toGreedyMatch localizer shorterArgs longerArgs =
435 toGreedyMatchHelp localizer shorterArgs longerArgs (GreedyMatch [] [])
438toGreedyMatchHelp :: L.Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
439toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
440 let
441 toYellowDoc tipe =
442 D.dullyellow (toDoc localizer RT.Func tipe)
443 in
444 case (shorterArgs, longerArgs) of
445 (x:xs, y:ys) ->
446 case diff localizer RT.Func x y of
447 Similar a b ->
448 toGreedyMatchHelp localizer xs ys $
449 GreedyMatch (a:shorterDocs) (b:longerDocs)
451 Different _ _ _ ->
452 toGreedyMatchHelp localizer shorterArgs ys $
453 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
455 ([], []) ->
456 Just match
458 ([], _:_) ->
459 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
461 (_:_, []) ->
462 Nothing
466-- RECORD DIFFS
469diffRecord :: L.Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff D.Doc
470diffRecord localizer fields1 ext1 fields2 ext2 =
471 let
472 only1 = Map.keys (Map.difference fields1 fields2)
473 only2 = Map.keys (Map.difference fields2 fields1)
474 in
475 if null only1 && null only2 then
476 case findBadOverlaps localizer fields1 fields2 of
477 [] ->
478 case diffExt ext1 ext2 of
479 Similar _ _ ->
480 Similar (toBoringRecord fields1 ext1) (toBoringRecord fields2 ext2)
482 Different dExt1 dExt2 problems ->
483 Different (RT.record [] dExt1) (RT.record [] dExt2) problems
485 overlaps@(bad:bads) ->
486 if length overlaps < Map.size fields1 then
487 Different
488 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
489 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
490 (foldr Bag.append Bag.empty (map _problems overlaps))
491 else
492 Different
493 (toOverlapRecord _doc1 bad bads ext1)
494 (toOverlapRecord _doc2 bad bads ext2)
495 (foldr Bag.append Bag.empty (map _problems overlaps))
497 else
498 Different
499 (toMissingDoc fields1 only1 ext1)
500 (toMissingDoc fields2 only2 ext2)
501 (Bag.one (FieldMismatch only1 only2))
504toOverlapDoc :: (BadOverlap -> D.Doc) -> BadOverlap -> (D.Doc, D.Doc)
505toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
506 (D.fromName field, getDoc overlap)
509toOverlapRecord :: (BadOverlap -> D.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> D.Doc
510toOverlapRecord getDoc bad bads ext =
511 let go = toOverlapDoc getDoc in
512 case ext of
513 Closed -> RT.record (map go (bad:bads)) Nothing
514 FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)
515 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
518toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> D.Doc
519toMissingDoc allFields uniqueFields ext =
520 case map emphasizeFieldName uniqueFields of
521 [] ->
522 toBoringRecord allFields ext
524 doc:docs ->
525 if length uniqueFields < Map.size allFields then
526 RT.recordSnippet doc docs
527 else
528 case ext of
529 Closed -> RT.record (doc:docs) Nothing
530 FlexOpen _ -> RT.recordSnippet doc docs
531 RigidOpen _ -> RT.recordSnippet doc docs
534emphasizeFieldName :: N.Name -> (D.Doc, D.Doc)
535emphasizeFieldName field =
536 ( D.dullyellow (D.fromName field), "..." )
539toBoringRecord :: Map.Map N.Name t -> Extension -> D.Doc
540toBoringRecord fields ext =
541 case ext of
542 Closed -> if Map.null fields then "{}" else "{ ... }"
543 FlexOpen _ -> "{ ... }"
544 RigidOpen _ -> "{ ... }"
548-- DIFF RECORD EXTENSION
551diffExt :: Extension -> Extension -> Diff (Maybe D.Doc)
552diffExt ext1 ext2 =
553 let
554 normal = Just . D.fromName
555 yellow = Just . D.dullyellow . D.fromName
557 different x y = Different x y Bag.empty
558 in
559 case ext1 of
560 Closed ->
561 case ext2 of
562 Closed -> Similar Nothing Nothing
563 FlexOpen y -> different Nothing (yellow y)
564 RigidOpen y -> different Nothing (yellow y)
566 FlexOpen x ->
567 case ext2 of
568 Closed -> different (yellow x) Nothing
569 FlexOpen y -> Similar (normal x) (normal y)
570 RigidOpen y -> Similar (normal x) (normal y)
572 RigidOpen x ->
573 case ext2 of
574 Closed -> different (yellow x) Nothing
575 FlexOpen y -> Similar (normal x) (normal y)
576 RigidOpen y ->
577 if x == y then
578 Similar (normal x) (normal y)
579 else
580 Different (yellow x) (yellow y) (Bag.one (BadRigidVar x (RigidVar y)))
584-- BAD OVERLAP
587data BadOverlap =
588 BadOverlap
589 { _field :: N.Name
590 , _doc1 :: D.Doc
591 , _doc2 :: D.Doc
592 , _problems :: Bag.Bag Problem
593 }
596findBadOverlaps :: L.Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
597findBadOverlaps localizer fields1 fields2 =
598 findBadOverlapsHelp [] $ Map.toList $
599 Map.intersectionWith (diff localizer RT.None) fields1 fields2
602findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff D.Doc)] -> [BadOverlap]
603findBadOverlapsHelp badOverlaps fieldPairs =
604 case fieldPairs of
605 [] ->
606 badOverlaps
608 (_, Similar _ _) : otherFieldPairs ->
609 findBadOverlapsHelp badOverlaps otherFieldPairs
611 (field, Different aDoc bDoc problems) : otherFieldPairs ->
612 findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs