git.iko.soy/elk
on 6f9825f help sign in
elk/src/Type/Error.hs
613 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 )
13 where
16import qualified Data.Map as Map
17import qualified Data.Maybe as Maybe
18import Data.Monoid ((<>))
20import qualified AST.Module.Name as ModuleName
21import qualified Data.Bag as Bag
22import qualified Elm.Name as N
23import qualified Reporting.Helpers as H
24import qualified Reporting.Render.Type as RT
28-- ERROR TYPES
31data Type
32 = Lambda Type Type [Type]
33 | Infinite
34 | Error
35 | FlexVar N.Name
36 | FlexSuper Super N.Name
37 | RigidVar N.Name
38 | RigidSuper Super N.Name
39 | Type ModuleName.Canonical N.Name [Type]
40 | Record (Map.Map N.Name Type) Extension
41 | Unit
42 | Tuple Type Type (Maybe Type)
43 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
46data Super
47 = Number
48 | Comparable
49 | Appendable
50 | CompAppend
53data Extension
54 = Closed
55 | FlexOpen N.Name
56 | RigidOpen N.Name
59iteratedDealias :: Type -> Type
60iteratedDealias tipe =
61 case tipe of
62 Alias _ _ _ realType ->
63 iteratedDealias realType
65 _ ->
66 tipe
70-- TO DOC
73type Localizer = Map.Map (ModuleName.Canonical, N.Name) String
76nameToDoc :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
77nameToDoc dict home@(ModuleName.Canonical _ moduleName) name =
78 case Map.lookup (home, name) dict of
79 Nothing ->
80 H.nameToDoc moduleName <> "." <> H.nameToDoc name
82 Just string ->
83 H.text string
86toDoc :: Localizer -> RT.Context -> Type -> H.Doc
87toDoc dict ctx tipe =
88 case tipe of
89 Lambda a b cs ->
90 RT.lambda ctx
91 (toDoc dict RT.Func a)
92 (toDoc dict RT.Func b)
93 (map (toDoc dict RT.Func) cs)
95 Infinite ->
96 "∞"
98 Error ->
99 "?"
101 FlexVar name ->
102 H.nameToDoc name
104 FlexSuper _ name ->
105 H.nameToDoc name
107 RigidVar name ->
108 H.nameToDoc name
110 RigidSuper _ name ->
111 H.nameToDoc name
113 Type home name args ->
114 RT.apply ctx
115 (nameToDoc dict home name)
116 (map (toDoc dict RT.App) args)
118 Record fields ext ->
119 let
120 entryToDocs (fieldName, fieldType) =
121 ( H.nameToDoc fieldName, toDoc dict RT.None fieldType )
123 fieldDocs =
124 map entryToDocs (Map.toList fields)
125 in
126 RT.record fieldDocs $
127 case ext of
128 Closed -> Nothing
129 FlexOpen x -> Just (H.nameToDoc x)
130 RigidOpen x -> Just (H.nameToDoc x)
132 Unit ->
133 "()"
135 Tuple a b maybeC ->
136 RT.tuple
137 (toDoc dict RT.None a)
138 (toDoc dict RT.None b)
139 (map (toDoc dict RT.None) (Maybe.maybeToList maybeC))
141 Alias home name args _ ->
142 RT.apply ctx
143 (nameToDoc dict home name)
144 (map (toDoc dict RT.App . snd) args)
148-- DIFF
151toDiffDocs :: Localizer -> Type -> Type -> (H.Doc, H.Doc, [Problem])
152toDiffDocs dict a b =
153 case diff dict RT.None a b of
154 Similar aDoc bDoc ->
155 (aDoc, bDoc, [])
157 Different aDoc bDoc problems ->
158 (aDoc, bDoc, Bag.toList problems)
161data Diff a
162 = Similar a a
163 | Different a a (Bag.Bag Problem)
166instance Functor Diff where
167 fmap func d =
168 case d of
169 Similar a b -> Similar (func a) (func b)
170 Different a b ps -> Different (func a) (func b) ps
173instance Applicative Diff where
174 pure a =
175 Similar a a
177 (<*>) dFunc dArg =
178 case dFunc of
179 Similar aFunc bFunc ->
180 case dArg of
181 Similar a b -> Similar (aFunc a) (bFunc b)
182 Different a b ps -> Different (aFunc a) (bFunc b) ps
184 Different aFunc bFunc ps ->
185 case dArg of
186 Similar a b -> Different (aFunc a) (bFunc b) ps
187 Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
191-- PROBLEMS
194data Problem
195 = FieldMismatch [N.Name] [N.Name]
196 | IntFloat
197 | StringFromInt
198 | StringFromFloat
199 | StringToInt
200 | StringToFloat
201 | AnythingToBool
202 | AnythingFromMaybe
203 | AnythingToList
204 | MissingArgs Int
205 | ReturnMismatch
206 | BadFlexSuper Super N.Name Type
207 | BadRigidVar N.Name Type
208 | BadRigidSuper Super N.Name Type
212-- COMPUTE DIFF
215diff :: Localizer -> RT.Context -> Type -> Type -> Diff H.Doc
216diff dict ctx tipe1 tipe2 =
217 case (tipe1, tipe2) of
218 (FlexVar x, FlexVar y) | x == y -> pure (H.nameToDoc x)
219 (FlexSuper _ x, FlexSuper _ y) | x == y -> pure (H.nameToDoc x)
220 (RigidVar x, RigidVar y) | x == y -> pure (H.nameToDoc x)
221 (RigidSuper _ x, RigidSuper _ y) | x == y -> pure (H.nameToDoc x)
223 (Infinite, Infinite) -> pure "∞"
224 (Error, Error) -> pure "?"
225 (Unit, Unit) -> pure "()"
227 (Tuple a b maybeC, Tuple x y maybeZ) ->
228 RT.tuple
229 <$> diff dict RT.None a x
230 <*> diff dict RT.None b y
231 <*>
232 case (maybeC, maybeZ) of
233 (Nothing, Nothing) -> pure []
234 (Just c , Nothing) -> Different [H.dullyellow (toDoc dict RT.None c)] [] Bag.empty
235 (Nothing, Just z ) -> Different [] [H.dullyellow (toDoc dict RT.None z)] Bag.empty
236 (Just c , Just z ) -> (:[]) <$> diff dict RT.None c z
238 (Record fields1 ext1, Record fields2 ext2) -> diffRecord dict fields1 ext1 fields2 ext2
240 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
241 RT.apply ctx (nameToDoc dict home1 name1) <$>
242 sequenceA (zipWith (diff dict RT.App) args1 args2)
244 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
245 RT.apply ctx (nameToDoc dict home1 name1) <$>
246 sequenceA (zipWith (diff dict RT.App) (map snd args1) (map snd args2))
248 (Alias _ _ _ alias1, other) -> diff dict ctx alias1 other
249 (other, Alias _ _ _ alias2) -> diff dict ctx other alias2
251 (Lambda a b cs, Lambda x y zs) -> diffLambda dict ctx (a:b:cs) (x:y:zs)
252 (Lambda a b cs, result ) -> diffLambda dict ctx (a:b:cs) [result]
253 (result , Lambda x y zs) -> diffLambda dict ctx [result] (x:y:zs)
255 (FlexVar x, other) -> Similar (H.nameToDoc x) (toDoc dict ctx other)
256 (other, FlexVar x) -> Similar (toDoc dict ctx other) (H.nameToDoc x)
258 pair ->
259 case pair of
260 (Type home name [t1], t2) | isMaybe home name && isSimilar t1 t2 ->
261 Different (yellowApply dict ctx home name t1) (toDoc dict ctx t2) (Bag.one AnythingFromMaybe)
263 (t1, Type home name [t2]) | isList home name && isSimilar t1 t2 ->
264 Different (toDoc dict ctx t1) (yellowApply dict ctx home name t2) (Bag.one AnythingToList)
266 _ ->
267 let
268 doc1 = H.dullyellow (toDoc dict ctx tipe1)
269 doc2 = H.dullyellow (toDoc dict ctx tipe2)
270 in
271 Different doc1 doc2 $
272 case pair of
273 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
274 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
275 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
276 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
277 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
278 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
280 (Type home1 name1 [], Type home2 name2 [])
281 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
282 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
283 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
284 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
285 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
286 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
287 | isBool home2 name2 -> Bag.one AnythingToBool
289 (_, _) -> Bag.empty
292isBool :: ModuleName.Canonical -> N.Name -> Bool
293isBool home name =
294 home == ModuleName.basics && name == N.bool
297isInt :: ModuleName.Canonical -> N.Name -> Bool
298isInt home name =
299 home == ModuleName.basics && name == N.int
302isFloat :: ModuleName.Canonical -> N.Name -> Bool
303isFloat home name =
304 home == ModuleName.basics && name == N.float
307isString :: ModuleName.Canonical -> N.Name -> Bool
308isString home name =
309 home == ModuleName.string && name == N.string
312isMaybe :: ModuleName.Canonical -> N.Name -> Bool
313isMaybe home name =
314 home == ModuleName.maybe && name == N.maybe
317isList :: ModuleName.Canonical -> N.Name -> Bool
318isList home name =
319 home == ModuleName.list && name == N.list
322isSimilar :: Type -> Type -> Bool
323isSimilar tipe1 tipe2 =
324 case diff Map.empty RT.None tipe1 tipe2 of
325 Similar _ _ -> True
326 Different _ _ _ -> False
329yellowApply :: Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> H.Doc
330yellowApply dict ctx home name tipe =
331 RT.apply ctx
332 (H.dullyellow (nameToDoc dict home name))
333 [toDoc dict RT.App tipe]
337-- DIFF LAMBDAS
340--
341-- INVARIANT: notNull types1 && notNull types2
342--
343diffLambda :: Localizer -> RT.Context -> [Type] -> [Type] -> Diff H.Doc
344diffLambda dict ctx types1 types2 =
345 let
346 (result1:revArgs1) = reverse types1
347 (result2:revArgs2) = reverse types2
349 numArgs1 = length revArgs1
350 numArgs2 = length revArgs2
352 resultDiff = diff dict RT.Func result1 result2
353 in
354 case resultDiff of
355 Similar resultDoc1 resultDoc2 ->
356 if numArgs1 == numArgs2 then
357 (\resultDoc revArgsDoc ->
358 let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
359 RT.lambda ctx x y zs
360 )
361 <$> resultDiff
362 <*> sequenceA (zipWith (diff dict RT.Func) revArgs1 revArgs2)
364 else if numArgs1 < numArgs2 then
365 diffArgMismatch dict ctx revArgs1 resultDoc1 revArgs2 resultDoc2
367 else
368 diffArgMismatch dict ctx revArgs2 resultDoc2 revArgs1 resultDoc1
370 Different resultDoc1 resultDoc2 problems ->
371 let
372 (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc dict RT.Func) revArgs1)
373 (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc dict RT.Func) revArgs2)
374 in
375 Different
376 (RT.lambda ctx x1 y1 zs1)
377 (RT.lambda ctx x2 y2 zs2)
378 (Bag.append (Bag.one ReturnMismatch) problems)
381--
382-- INVARIANT: notNull shortRevArgs && notNull longRevArgs
383--
384diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
385diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
386 case toGreedyMatch dict shortRevArgs longRevArgs of
387 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
388 let
389 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
390 (x:y:zs) = reverse (longResult:longRevArgDocs)
391 in
392 Different
393 (RT.lambda ctx a b cs)
394 (RT.lambda ctx x y zs)
395 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
397 Nothing ->
398 case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) of
399 Just (GreedyMatch shortArgDocs longArgDocs) ->
400 let
401 (a:b:cs) = shortArgDocs ++ [shortResult]
402 (x:y:zs) = longArgDocs ++ [longResult ]
403 in
404 Different
405 (RT.lambda ctx a b cs)
406 (RT.lambda ctx x y zs)
407 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
409 Nothing ->
410 let
411 toYellowDoc tipe =
412 H.dullyellow (toDoc dict RT.Func tipe)
414 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
415 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
416 in
417 Different
418 (RT.lambda ctx a b cs)
419 (RT.lambda ctx x y zs)
420 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
424-- GREEDY ARG MATCHER
427data GreedyMatch =
428 GreedyMatch [H.Doc] [H.Doc]
431--
432-- INVARIANT: length shorterArgs < length longerArgs
433--
434toGreedyMatch :: Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
435toGreedyMatch dict shorterArgs longerArgs =
436 toGreedyMatchHelp dict shorterArgs longerArgs (GreedyMatch [] [])
439toGreedyMatchHelp :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
440toGreedyMatchHelp dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
441 let
442 toYellowDoc tipe =
443 H.dullyellow (toDoc dict RT.Func tipe)
444 in
445 case (shorterArgs, longerArgs) of
446 (x:xs, y:ys) ->
447 case diff dict RT.Func x y of
448 Similar a b ->
449 toGreedyMatchHelp dict xs ys $
450 GreedyMatch (a:shorterDocs) (b:longerDocs)
452 Different _ _ _ ->
453 toGreedyMatchHelp dict shorterArgs ys $
454 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
456 ([], []) ->
457 Just match
459 ([], _:_) ->
460 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
462 (_:_, []) ->
463 Nothing
467-- RECORD DIFFS
470diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
471diffRecord dict fields1 ext1 fields2 ext2 =
472 let
473 only1 = Map.keys (Map.difference fields1 fields2)
474 only2 = Map.keys (Map.difference fields2 fields1)
475 in
476 if null only1 && null only2 then
477 case findBadOverlaps dict fields1 fields2 of
478 [] ->
479 case diffExt ext1 ext2 of
480 Similar _ _ ->
481 Similar (toBoringRecord fields1 ext1) (toBoringRecord fields2 ext2)
483 Different dExt1 dExt2 problems ->
484 Different (RT.record [] dExt1) (RT.record [] dExt2) problems
486 overlaps@(bad:bads) ->
487 if length overlaps < Map.size fields1 then
488 Different
489 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
490 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
491 (foldr Bag.append Bag.empty (map _problems overlaps))
492 else
493 Different
494 (toOverlapRecord _doc1 bad bads ext1)
495 (toOverlapRecord _doc2 bad bads ext2)
496 (foldr Bag.append Bag.empty (map _problems overlaps))
498 else
499 Different
500 (toMissingDoc fields1 only1 ext1)
501 (toMissingDoc fields2 only2 ext2)
502 (Bag.one (FieldMismatch only1 only2))
505toOverlapDoc :: (BadOverlap -> H.Doc) -> BadOverlap -> (H.Doc, H.Doc)
506toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
507 (H.nameToDoc field, getDoc overlap)
510toOverlapRecord :: (BadOverlap -> H.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> H.Doc
511toOverlapRecord getDoc bad bads ext =
512 let go = toOverlapDoc getDoc in
513 case ext of
514 Closed -> RT.record (map go (bad:bads)) Nothing
515 FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)
516 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
519toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> H.Doc
520toMissingDoc allFields uniqueFields ext =
521 case map emphasizeFieldName uniqueFields of
522 [] ->
523 toBoringRecord allFields ext
525 doc:docs ->
526 if length uniqueFields < Map.size allFields then
527 RT.recordSnippet doc docs
528 else
529 case ext of
530 Closed -> RT.record (doc:docs) Nothing
531 FlexOpen _ -> RT.recordSnippet doc docs
532 RigidOpen _ -> RT.recordSnippet doc docs
535emphasizeFieldName :: N.Name -> (H.Doc, H.Doc)
536emphasizeFieldName field =
537 ( H.dullyellow (H.nameToDoc field), "..." )
540toBoringRecord :: Map.Map N.Name t -> Extension -> H.Doc
541toBoringRecord fields ext =
542 case ext of
543 Closed -> if Map.null fields then "{}" else "{ ... }"
544 FlexOpen _ -> "{ ... }"
545 RigidOpen _ -> "{ ... }"
549-- DIFF RECORD EXTENSION
552diffExt :: Extension -> Extension -> Diff (Maybe H.Doc)
553diffExt ext1 ext2 =
554 let
555 normal = Just . H.nameToDoc
556 yellow = Just . H.dullyellow . H.nameToDoc
558 different x y = Different x y Bag.empty
559 in
560 case ext1 of
561 Closed ->
562 case ext2 of
563 Closed -> Similar Nothing Nothing
564 FlexOpen y -> different Nothing (yellow y)
565 RigidOpen y -> different Nothing (yellow y)
567 FlexOpen x ->
568 case ext2 of
569 Closed -> different (yellow x) Nothing
570 FlexOpen y -> Similar (normal x) (normal y)
571 RigidOpen y -> Similar (normal x) (normal y)
573 RigidOpen x ->
574 case ext2 of
575 Closed -> different (yellow x) Nothing
576 FlexOpen y -> Similar (normal x) (normal y)
577 RigidOpen y ->
578 if x == y then
579 Similar (normal x) (normal y)
580 else
581 Different (yellow x) (yellow y) (Bag.one (BadRigidVar x (RigidVar y)))
585-- BAD OVERLAP
588data BadOverlap =
589 BadOverlap
590 { _field :: N.Name
591 , _doc1 :: H.Doc
592 , _doc2 :: H.Doc
593 , _problems :: Bag.Bag Problem
594 }
597findBadOverlaps :: Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
598findBadOverlaps dict fields1 fields2 =
599 findBadOverlapsHelp [] $ Map.toList $
600 Map.intersectionWith (diff dict RT.None) fields1 fields2
603findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff H.Doc)] -> [BadOverlap]
604findBadOverlapsHelp badOverlaps fieldPairs =
605 case fieldPairs of
606 [] ->
607 badOverlaps
609 (_, Similar _ _) : otherFieldPairs ->
610 findBadOverlapsHelp badOverlaps otherFieldPairs
612 (field, Different aDoc bDoc problems) : otherFieldPairs ->
613 findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs