git.iko.soy/elk
on f5f9ed0 help sign in
elk/src/Type/Error.hs
617 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 , isList
16 )
17 where
20import qualified Data.Map as Map
21import qualified Data.Maybe as Maybe
22import Data.Monoid ((<>))
24import qualified AST.Module.Name as ModuleName
25import qualified Data.Bag as Bag
26import qualified Elm.Name as N
27import qualified Reporting.Helpers as H
28import qualified Reporting.Render.Type as RT
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
77type Localizer = Map.Map (ModuleName.Canonical, N.Name) String
80nameToDoc :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
81nameToDoc dict home@(ModuleName.Canonical _ moduleName) name =
82 case Map.lookup (home, name) dict of
83 Nothing ->
84 H.nameToDoc moduleName <> "." <> H.nameToDoc name
86 Just string ->
87 H.text string
90toDoc :: Localizer -> RT.Context -> Type -> H.Doc
91toDoc dict ctx tipe =
92 case tipe of
93 Lambda a b cs ->
94 RT.lambda ctx
95 (toDoc dict RT.Func a)
96 (toDoc dict RT.Func b)
97 (map (toDoc dict RT.Func) cs)
99 Infinite ->
100 "∞"
102 Error ->
103 "?"
105 FlexVar name ->
106 H.nameToDoc name
108 FlexSuper _ name ->
109 H.nameToDoc name
111 RigidVar name ->
112 H.nameToDoc name
114 RigidSuper _ name ->
115 H.nameToDoc name
117 Type home name args ->
118 RT.apply ctx
119 (nameToDoc dict home name)
120 (map (toDoc dict RT.App) args)
122 Record fields ext ->
123 let
124 entryToDocs (fieldName, fieldType) =
125 ( H.nameToDoc fieldName, toDoc dict RT.None fieldType )
127 fieldDocs =
128 map entryToDocs (Map.toList fields)
129 in
130 RT.record fieldDocs $
131 case ext of
132 Closed -> Nothing
133 FlexOpen x -> Just (H.nameToDoc x)
134 RigidOpen x -> Just (H.nameToDoc x)
136 Unit ->
137 "()"
139 Tuple a b maybeC ->
140 RT.tuple
141 (toDoc dict RT.None a)
142 (toDoc dict RT.None b)
143 (map (toDoc dict RT.None) (Maybe.maybeToList maybeC))
145 Alias home name args _ ->
146 RT.apply ctx
147 (nameToDoc dict home name)
148 (map (toDoc dict RT.App . snd) args)
152-- DIFF
155toDiffDocs :: Localizer -> Type -> Type -> (H.Doc, H.Doc, [Problem])
156toDiffDocs dict a b =
157 case diff dict RT.None a b of
158 Similar aDoc bDoc ->
159 (aDoc, bDoc, [])
161 Different aDoc bDoc problems ->
162 (aDoc, bDoc, Bag.toList problems)
165data Diff a
166 = Similar a a
167 | Different a a (Bag.Bag Problem)
170instance Functor Diff where
171 fmap func d =
172 case d of
173 Similar a b -> Similar (func a) (func b)
174 Different a b ps -> Different (func a) (func b) ps
177instance Applicative Diff where
178 pure a =
179 Similar a a
181 (<*>) dFunc dArg =
182 case dFunc of
183 Similar aFunc bFunc ->
184 case dArg of
185 Similar a b -> Similar (aFunc a) (bFunc b)
186 Different a b ps -> Different (aFunc a) (bFunc b) ps
188 Different aFunc bFunc ps ->
189 case dArg of
190 Similar a b -> Different (aFunc a) (bFunc b) ps
191 Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
195-- PROBLEMS
198data Problem
199 = FieldMismatch [N.Name] [N.Name]
200 | IntFloat
201 | StringFromInt
202 | StringFromFloat
203 | StringToInt
204 | StringToFloat
205 | AnythingToBool
206 | AnythingFromMaybe
207 | AnythingToList
208 | MissingArgs Int
209 | ReturnMismatch
210 | BadFlexSuper Super N.Name Type
211 | BadRigidVar N.Name Type
212 | BadRigidSuper Super N.Name Type
216-- COMPUTE DIFF
219diff :: Localizer -> RT.Context -> Type -> Type -> Diff H.Doc
220diff dict ctx tipe1 tipe2 =
221 case (tipe1, tipe2) of
222 (FlexVar x, FlexVar y) | x == y -> pure (H.nameToDoc x)
223 (FlexSuper _ x, FlexSuper _ y) | x == y -> pure (H.nameToDoc x)
224 (RigidVar x, RigidVar y) | x == y -> pure (H.nameToDoc x)
225 (RigidSuper _ x, RigidSuper _ y) | x == y -> pure (H.nameToDoc x)
227 (Infinite, Infinite) -> pure "∞"
228 (Error, Error) -> pure "?"
229 (Unit, Unit) -> pure "()"
231 (Tuple a b maybeC, Tuple x y maybeZ) ->
232 RT.tuple
233 <$> diff dict RT.None a x
234 <*> diff dict RT.None b y
235 <*>
236 case (maybeC, maybeZ) of
237 (Nothing, Nothing) -> pure []
238 (Just c , Nothing) -> Different [H.dullyellow (toDoc dict RT.None c)] [] Bag.empty
239 (Nothing, Just z ) -> Different [] [H.dullyellow (toDoc dict RT.None z)] Bag.empty
240 (Just c , Just z ) -> (:[]) <$> diff dict RT.None c z
242 (Record fields1 ext1, Record fields2 ext2) -> diffRecord dict fields1 ext1 fields2 ext2
244 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
245 RT.apply ctx (nameToDoc dict home1 name1) <$>
246 sequenceA (zipWith (diff dict RT.App) args1 args2)
248 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
249 RT.apply ctx (nameToDoc dict home1 name1) <$>
250 sequenceA (zipWith (diff dict RT.App) (map snd args1) (map snd args2))
252 (Alias _ _ _ alias1, other) -> diff dict ctx alias1 other
253 (other, Alias _ _ _ alias2) -> diff dict ctx other alias2
255 (Lambda a b cs, Lambda x y zs) -> diffLambda dict ctx (a:b:cs) (x:y:zs)
256 (Lambda a b cs, result ) -> diffLambda dict ctx (a:b:cs) [result]
257 (result , Lambda x y zs) -> diffLambda dict ctx [result] (x:y:zs)
259 (FlexVar x, other) -> Similar (H.nameToDoc x) (toDoc dict ctx other)
260 (other, FlexVar x) -> Similar (toDoc dict ctx other) (H.nameToDoc x)
262 pair ->
263 case pair of
264 (Type home name [t1], t2) | isMaybe home name && isSimilar t1 t2 ->
265 Different (yellowApply dict ctx home name t1) (toDoc dict ctx t2) (Bag.one AnythingFromMaybe)
267 (t1, Type home name [t2]) | isList home name && isSimilar t1 t2 ->
268 Different (toDoc dict ctx t1) (yellowApply dict ctx home name t2) (Bag.one AnythingToList)
270 _ ->
271 let
272 doc1 = H.dullyellow (toDoc dict ctx tipe1)
273 doc2 = H.dullyellow (toDoc dict ctx tipe2)
274 in
275 Different doc1 doc2 $
276 case pair of
277 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
278 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
279 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
280 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
281 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
282 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
284 (Type home1 name1 [], Type home2 name2 [])
285 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
286 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
287 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
288 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
289 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
290 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
291 | isBool home2 name2 -> Bag.one AnythingToBool
293 (_, _) -> Bag.empty
296isBool :: ModuleName.Canonical -> N.Name -> Bool
297isBool home name =
298 home == ModuleName.basics && name == N.bool
301isInt :: ModuleName.Canonical -> N.Name -> Bool
302isInt home name =
303 home == ModuleName.basics && name == N.int
306isFloat :: ModuleName.Canonical -> N.Name -> Bool
307isFloat home name =
308 home == ModuleName.basics && name == N.float
311isString :: ModuleName.Canonical -> N.Name -> Bool
312isString home name =
313 home == ModuleName.string && name == N.string
316isMaybe :: ModuleName.Canonical -> N.Name -> Bool
317isMaybe home name =
318 home == ModuleName.maybe && name == N.maybe
321isList :: ModuleName.Canonical -> N.Name -> Bool
322isList home name =
323 home == ModuleName.list && name == N.list
326isSimilar :: Type -> Type -> Bool
327isSimilar tipe1 tipe2 =
328 case diff Map.empty RT.None tipe1 tipe2 of
329 Similar _ _ -> True
330 Different _ _ _ -> False
333yellowApply :: Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> H.Doc
334yellowApply dict ctx home name tipe =
335 RT.apply ctx
336 (H.dullyellow (nameToDoc dict home name))
337 [toDoc dict RT.App tipe]
341-- DIFF LAMBDAS
344--
345-- INVARIANT: notNull types1 && notNull types2
346--
347diffLambda :: Localizer -> RT.Context -> [Type] -> [Type] -> Diff H.Doc
348diffLambda dict ctx types1 types2 =
349 let
350 (result1:revArgs1) = reverse types1
351 (result2:revArgs2) = reverse types2
353 numArgs1 = length revArgs1
354 numArgs2 = length revArgs2
356 resultDiff = diff dict RT.Func result1 result2
357 in
358 case resultDiff of
359 Similar resultDoc1 resultDoc2 ->
360 if numArgs1 == numArgs2 then
361 (\resultDoc revArgsDoc ->
362 let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
363 RT.lambda ctx x y zs
364 )
365 <$> resultDiff
366 <*> sequenceA (zipWith (diff dict RT.Func) revArgs1 revArgs2)
368 else if numArgs1 < numArgs2 then
369 diffArgMismatch dict ctx revArgs1 resultDoc1 revArgs2 resultDoc2
371 else
372 diffArgMismatch dict ctx revArgs2 resultDoc2 revArgs1 resultDoc1
374 Different resultDoc1 resultDoc2 problems ->
375 let
376 (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc dict RT.Func) revArgs1)
377 (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc dict RT.Func) revArgs2)
378 in
379 Different
380 (RT.lambda ctx x1 y1 zs1)
381 (RT.lambda ctx x2 y2 zs2)
382 (Bag.append (Bag.one ReturnMismatch) problems)
385--
386-- INVARIANT: notNull shortRevArgs && notNull longRevArgs
387--
388diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
389diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
390 case toGreedyMatch dict shortRevArgs longRevArgs of
391 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
392 let
393 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
394 (x:y:zs) = reverse (longResult:longRevArgDocs)
395 in
396 Different
397 (RT.lambda ctx a b cs)
398 (RT.lambda ctx x y zs)
399 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
401 Nothing ->
402 case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) of
403 Just (GreedyMatch shortArgDocs longArgDocs) ->
404 let
405 (a:b:cs) = shortArgDocs ++ [shortResult]
406 (x:y:zs) = longArgDocs ++ [longResult ]
407 in
408 Different
409 (RT.lambda ctx a b cs)
410 (RT.lambda ctx x y zs)
411 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
413 Nothing ->
414 let
415 toYellowDoc tipe =
416 H.dullyellow (toDoc dict RT.Func tipe)
418 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
419 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
420 in
421 Different
422 (RT.lambda ctx a b cs)
423 (RT.lambda ctx x y zs)
424 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
428-- GREEDY ARG MATCHER
431data GreedyMatch =
432 GreedyMatch [H.Doc] [H.Doc]
435--
436-- INVARIANT: length shorterArgs < length longerArgs
437--
438toGreedyMatch :: Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
439toGreedyMatch dict shorterArgs longerArgs =
440 toGreedyMatchHelp dict shorterArgs longerArgs (GreedyMatch [] [])
443toGreedyMatchHelp :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
444toGreedyMatchHelp dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
445 let
446 toYellowDoc tipe =
447 H.dullyellow (toDoc dict RT.Func tipe)
448 in
449 case (shorterArgs, longerArgs) of
450 (x:xs, y:ys) ->
451 case diff dict RT.Func x y of
452 Similar a b ->
453 toGreedyMatchHelp dict xs ys $
454 GreedyMatch (a:shorterDocs) (b:longerDocs)
456 Different _ _ _ ->
457 toGreedyMatchHelp dict shorterArgs ys $
458 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
460 ([], []) ->
461 Just match
463 ([], _:_) ->
464 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
466 (_:_, []) ->
467 Nothing
471-- RECORD DIFFS
474diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
475diffRecord dict fields1 ext1 fields2 ext2 =
476 let
477 only1 = Map.keys (Map.difference fields1 fields2)
478 only2 = Map.keys (Map.difference fields2 fields1)
479 in
480 if null only1 && null only2 then
481 case findBadOverlaps dict fields1 fields2 of
482 [] ->
483 case diffExt ext1 ext2 of
484 Similar _ _ ->
485 Similar (toBoringRecord fields1 ext1) (toBoringRecord fields2 ext2)
487 Different dExt1 dExt2 problems ->
488 Different (RT.record [] dExt1) (RT.record [] dExt2) problems
490 overlaps@(bad:bads) ->
491 if length overlaps < Map.size fields1 then
492 Different
493 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
494 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
495 (foldr Bag.append Bag.empty (map _problems overlaps))
496 else
497 Different
498 (toOverlapRecord _doc1 bad bads ext1)
499 (toOverlapRecord _doc2 bad bads ext2)
500 (foldr Bag.append Bag.empty (map _problems overlaps))
502 else
503 Different
504 (toMissingDoc fields1 only1 ext1)
505 (toMissingDoc fields2 only2 ext2)
506 (Bag.one (FieldMismatch only1 only2))
509toOverlapDoc :: (BadOverlap -> H.Doc) -> BadOverlap -> (H.Doc, H.Doc)
510toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
511 (H.nameToDoc field, getDoc overlap)
514toOverlapRecord :: (BadOverlap -> H.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> H.Doc
515toOverlapRecord getDoc bad bads ext =
516 let go = toOverlapDoc getDoc in
517 case ext of
518 Closed -> RT.record (map go (bad:bads)) Nothing
519 FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)
520 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
523toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> H.Doc
524toMissingDoc allFields uniqueFields ext =
525 case map emphasizeFieldName uniqueFields of
526 [] ->
527 toBoringRecord allFields ext
529 doc:docs ->
530 if length uniqueFields < Map.size allFields then
531 RT.recordSnippet doc docs
532 else
533 case ext of
534 Closed -> RT.record (doc:docs) Nothing
535 FlexOpen _ -> RT.recordSnippet doc docs
536 RigidOpen _ -> RT.recordSnippet doc docs
539emphasizeFieldName :: N.Name -> (H.Doc, H.Doc)
540emphasizeFieldName field =
541 ( H.dullyellow (H.nameToDoc field), "..." )
544toBoringRecord :: Map.Map N.Name t -> Extension -> H.Doc
545toBoringRecord fields ext =
546 case ext of
547 Closed -> if Map.null fields then "{}" else "{ ... }"
548 FlexOpen _ -> "{ ... }"
549 RigidOpen _ -> "{ ... }"
553-- DIFF RECORD EXTENSION
556diffExt :: Extension -> Extension -> Diff (Maybe H.Doc)
557diffExt ext1 ext2 =
558 let
559 normal = Just . H.nameToDoc
560 yellow = Just . H.dullyellow . H.nameToDoc
562 different x y = Different x y Bag.empty
563 in
564 case ext1 of
565 Closed ->
566 case ext2 of
567 Closed -> Similar Nothing Nothing
568 FlexOpen y -> different Nothing (yellow y)
569 RigidOpen y -> different Nothing (yellow y)
571 FlexOpen x ->
572 case ext2 of
573 Closed -> different (yellow x) Nothing
574 FlexOpen y -> Similar (normal x) (normal y)
575 RigidOpen y -> Similar (normal x) (normal y)
577 RigidOpen x ->
578 case ext2 of
579 Closed -> different (yellow x) Nothing
580 FlexOpen y -> Similar (normal x) (normal y)
581 RigidOpen y ->
582 if x == y then
583 Similar (normal x) (normal y)
584 else
585 Different (yellow x) (yellow y) (Bag.one (BadRigidVar x (RigidVar y)))
589-- BAD OVERLAP
592data BadOverlap =
593 BadOverlap
594 { _field :: N.Name
595 , _doc1 :: H.Doc
596 , _doc2 :: H.Doc
597 , _problems :: Bag.Bag Problem
598 }
601findBadOverlaps :: Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
602findBadOverlaps dict fields1 fields2 =
603 findBadOverlapsHelp [] $ Map.toList $
604 Map.intersectionWith (diff dict RT.None) fields1 fields2
607findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff H.Doc)] -> [BadOverlap]
608findBadOverlapsHelp badOverlaps fieldPairs =
609 case fieldPairs of
610 [] ->
611 badOverlaps
613 (_, Similar _ _) : otherFieldPairs ->
614 findBadOverlapsHelp badOverlaps otherFieldPairs
616 (field, Different aDoc bDoc problems) : otherFieldPairs ->
617 findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs