git.iko.soy/elk
on 2ce0625 help sign in
elk/compiler/src/Type/Error.hs
623 lines 18 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)
257 (Lambda a b cs, result ) -> diffLambda dict ctx (a:b:cs) [result]
258 (result , Lambda x y zs) -> diffLambda dict ctx [result] (x:y:zs)
260 (FlexVar x, other) -> Similar (H.nameToDoc x) (toDoc dict ctx other)
261 (other, FlexVar x) -> Similar (toDoc dict ctx other) (H.nameToDoc x)
263 pair ->
264 case pair of
265 (Type home name [t1], t2) | isMaybe home name && isSimilar t1 t2 ->
266 Different (yellowApply dict ctx home name t1) (toDoc dict ctx t2) (Bag.one AnythingFromMaybe)
268 (t1, Type home name [t2]) | isList home name && isSimilar t1 t2 ->
269 Different (toDoc dict ctx t1) (yellowApply dict ctx home name t2) (Bag.one AnythingToList)
271 _ ->
272 let
273 doc1 = H.dullyellow (toDoc dict ctx tipe1)
274 doc2 = H.dullyellow (toDoc dict ctx tipe2)
275 in
276 Different doc1 doc2 $
277 case pair of
278 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
279 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
280 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
281 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
282 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
283 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
285 (Type home1 name1 [], Type home2 name2 [])
286 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
287 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
288 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
289 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
290 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
291 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
292 | isBool home2 name2 -> Bag.one AnythingToBool
294 (_, _) -> Bag.empty
297isBool :: ModuleName.Canonical -> N.Name -> Bool
298isBool home name =
299 home == ModuleName.basics && name == N.bool
302isInt :: ModuleName.Canonical -> N.Name -> Bool
303isInt home name =
304 home == ModuleName.basics && name == N.int
307isFloat :: ModuleName.Canonical -> N.Name -> Bool
308isFloat home name =
309 home == ModuleName.basics && name == N.float
312isString :: ModuleName.Canonical -> N.Name -> Bool
313isString home name =
314 home == ModuleName.string && name == N.string
317isChar :: ModuleName.Canonical -> N.Name -> Bool
318isChar home name =
319 home == ModuleName.char && name == N.char
322isMaybe :: ModuleName.Canonical -> N.Name -> Bool
323isMaybe home name =
324 home == ModuleName.maybe && name == N.maybe
327isList :: ModuleName.Canonical -> N.Name -> Bool
328isList home name =
329 home == ModuleName.list && name == N.list
332isSimilar :: Type -> Type -> Bool
333isSimilar tipe1 tipe2 =
334 case diff Map.empty RT.None tipe1 tipe2 of
335 Similar _ _ -> True
336 Different _ _ _ -> False
339yellowApply :: Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> H.Doc
340yellowApply dict ctx home name tipe =
341 RT.apply ctx
342 (H.dullyellow (nameToDoc dict home name))
343 [toDoc dict RT.App tipe]
347-- DIFF LAMBDAS
350--
351-- INVARIANT: notNull types1 && notNull types2
352--
353diffLambda :: Localizer -> RT.Context -> [Type] -> [Type] -> Diff H.Doc
354diffLambda dict ctx types1 types2 =
355 let
356 (result1:revArgs1) = reverse types1
357 (result2:revArgs2) = reverse types2
359 numArgs1 = length revArgs1
360 numArgs2 = length revArgs2
362 resultDiff = diff dict RT.Func result1 result2
363 in
364 case resultDiff of
365 Similar resultDoc1 resultDoc2 ->
366 if numArgs1 == numArgs2 then
367 (\resultDoc revArgsDoc ->
368 let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
369 RT.lambda ctx x y zs
370 )
371 <$> resultDiff
372 <*> sequenceA (zipWith (diff dict RT.Func) revArgs1 revArgs2)
374 else if numArgs1 < numArgs2 then
375 diffArgMismatch dict ctx revArgs1 resultDoc1 revArgs2 resultDoc2
377 else
378 diffArgMismatch dict ctx revArgs2 resultDoc2 revArgs1 resultDoc1
380 Different resultDoc1 resultDoc2 problems ->
381 let
382 (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc dict RT.Func) revArgs1)
383 (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc dict RT.Func) revArgs2)
384 in
385 Different
386 (RT.lambda ctx x1 y1 zs1)
387 (RT.lambda ctx x2 y2 zs2)
388 (Bag.append (Bag.one ReturnMismatch) problems)
391--
392-- INVARIANT: notNull shortRevArgs && notNull longRevArgs
393--
394diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
395diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
396 case toGreedyMatch dict shortRevArgs longRevArgs of
397 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
398 let
399 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
400 (x:y:zs) = reverse (longResult:longRevArgDocs)
401 in
402 Different
403 (RT.lambda ctx a b cs)
404 (RT.lambda ctx x y zs)
405 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
407 Nothing ->
408 case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) of
409 Just (GreedyMatch shortArgDocs longArgDocs) ->
410 let
411 (a:b:cs) = shortArgDocs ++ [shortResult]
412 (x:y:zs) = longArgDocs ++ [longResult ]
413 in
414 Different
415 (RT.lambda ctx a b cs)
416 (RT.lambda ctx x y zs)
417 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
419 Nothing ->
420 let
421 toYellowDoc tipe =
422 H.dullyellow (toDoc dict RT.Func tipe)
424 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
425 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
426 in
427 Different
428 (RT.lambda ctx a b cs)
429 (RT.lambda ctx x y zs)
430 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
434-- GREEDY ARG MATCHER
437data GreedyMatch =
438 GreedyMatch [H.Doc] [H.Doc]
441--
442-- INVARIANT: length shorterArgs < length longerArgs
443--
444toGreedyMatch :: Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
445toGreedyMatch dict shorterArgs longerArgs =
446 toGreedyMatchHelp dict shorterArgs longerArgs (GreedyMatch [] [])
449toGreedyMatchHelp :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
450toGreedyMatchHelp dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
451 let
452 toYellowDoc tipe =
453 H.dullyellow (toDoc dict RT.Func tipe)
454 in
455 case (shorterArgs, longerArgs) of
456 (x:xs, y:ys) ->
457 case diff dict RT.Func x y of
458 Similar a b ->
459 toGreedyMatchHelp dict xs ys $
460 GreedyMatch (a:shorterDocs) (b:longerDocs)
462 Different _ _ _ ->
463 toGreedyMatchHelp dict shorterArgs ys $
464 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
466 ([], []) ->
467 Just match
469 ([], _:_) ->
470 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
472 (_:_, []) ->
473 Nothing
477-- RECORD DIFFS
480diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
481diffRecord dict fields1 ext1 fields2 ext2 =
482 let
483 only1 = Map.keys (Map.difference fields1 fields2)
484 only2 = Map.keys (Map.difference fields2 fields1)
485 in
486 if null only1 && null only2 then
487 case findBadOverlaps dict fields1 fields2 of
488 [] ->
489 case diffExt ext1 ext2 of
490 Similar _ _ ->
491 Similar (toBoringRecord fields1 ext1) (toBoringRecord fields2 ext2)
493 Different dExt1 dExt2 problems ->
494 Different (RT.record [] dExt1) (RT.record [] dExt2) problems
496 overlaps@(bad:bads) ->
497 if length overlaps < Map.size fields1 then
498 Different
499 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
500 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
501 (foldr Bag.append Bag.empty (map _problems overlaps))
502 else
503 Different
504 (toOverlapRecord _doc1 bad bads ext1)
505 (toOverlapRecord _doc2 bad bads ext2)
506 (foldr Bag.append Bag.empty (map _problems overlaps))
508 else
509 Different
510 (toMissingDoc fields1 only1 ext1)
511 (toMissingDoc fields2 only2 ext2)
512 (Bag.one (FieldMismatch only1 only2))
515toOverlapDoc :: (BadOverlap -> H.Doc) -> BadOverlap -> (H.Doc, H.Doc)
516toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
517 (H.nameToDoc field, getDoc overlap)
520toOverlapRecord :: (BadOverlap -> H.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> H.Doc
521toOverlapRecord getDoc bad bads ext =
522 let go = toOverlapDoc getDoc in
523 case ext of
524 Closed -> RT.record (map go (bad:bads)) Nothing
525 FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)
526 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
529toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> H.Doc
530toMissingDoc allFields uniqueFields ext =
531 case map emphasizeFieldName uniqueFields of
532 [] ->
533 toBoringRecord allFields ext
535 doc:docs ->
536 if length uniqueFields < Map.size allFields then
537 RT.recordSnippet doc docs
538 else
539 case ext of
540 Closed -> RT.record (doc:docs) Nothing
541 FlexOpen _ -> RT.recordSnippet doc docs
542 RigidOpen _ -> RT.recordSnippet doc docs
545emphasizeFieldName :: N.Name -> (H.Doc, H.Doc)
546emphasizeFieldName field =
547 ( H.dullyellow (H.nameToDoc field), "..." )
550toBoringRecord :: Map.Map N.Name t -> Extension -> H.Doc
551toBoringRecord fields ext =
552 case ext of
553 Closed -> if Map.null fields then "{}" else "{ ... }"
554 FlexOpen _ -> "{ ... }"
555 RigidOpen _ -> "{ ... }"
559-- DIFF RECORD EXTENSION
562diffExt :: Extension -> Extension -> Diff (Maybe H.Doc)
563diffExt ext1 ext2 =
564 let
565 normal = Just . H.nameToDoc
566 yellow = Just . H.dullyellow . H.nameToDoc
568 different x y = Different x y Bag.empty
569 in
570 case ext1 of
571 Closed ->
572 case ext2 of
573 Closed -> Similar Nothing Nothing
574 FlexOpen y -> different Nothing (yellow y)
575 RigidOpen y -> different Nothing (yellow y)
577 FlexOpen x ->
578 case ext2 of
579 Closed -> different (yellow x) Nothing
580 FlexOpen y -> Similar (normal x) (normal y)
581 RigidOpen y -> Similar (normal x) (normal y)
583 RigidOpen x ->
584 case ext2 of
585 Closed -> different (yellow x) Nothing
586 FlexOpen y -> Similar (normal x) (normal y)
587 RigidOpen y ->
588 if x == y then
589 Similar (normal x) (normal y)
590 else
591 Different (yellow x) (yellow y) (Bag.one (BadRigidVar x (RigidVar y)))
595-- BAD OVERLAP
598data BadOverlap =
599 BadOverlap
600 { _field :: N.Name
601 , _doc1 :: H.Doc
602 , _doc2 :: H.Doc
603 , _problems :: Bag.Bag Problem
604 }
607findBadOverlaps :: Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
608findBadOverlaps dict fields1 fields2 =
609 findBadOverlapsHelp [] $ Map.toList $
610 Map.intersectionWith (diff dict RT.None) fields1 fields2
613findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff H.Doc)] -> [BadOverlap]
614findBadOverlapsHelp badOverlaps fieldPairs =
615 case fieldPairs of
616 [] ->
617 badOverlaps
619 (_, Similar _ _) : otherFieldPairs ->
620 findBadOverlapsHelp badOverlaps otherFieldPairs
622 (field, Different aDoc bDoc problems) : otherFieldPairs ->
623 findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs