git.iko.soy/elk
on 2b0bc09 help sign in
elk/compiler/src/Type/Error.hs
643 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 , Problem(..)
10 , toComparison
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
55 deriving (Eq)
58data Extension
59 = Closed
60 | FlexOpen N.Name
61 | RigidOpen N.Name
64iteratedDealias :: Type -> Type
65iteratedDealias tipe =
66 case tipe of
67 Alias _ _ _ real ->
68 iteratedDealias real
70 _ ->
71 tipe
75-- TO DOC
78nameToDoc :: L.Localizer -> ModuleName.Canonical -> N.Name -> D.Doc
79nameToDoc localizer (ModuleName.Canonical _ home) name =
80 L.toDoc localizer home name
83toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
84toDoc localizer ctx tipe =
85 case tipe of
86 Lambda a b cs ->
87 RT.lambda ctx
88 (toDoc localizer RT.Func a)
89 (toDoc localizer RT.Func b)
90 (map (toDoc localizer RT.Func) cs)
92 Infinite ->
93 "∞"
95 Error ->
96 "?"
98 FlexVar name ->
99 D.fromName name
101 FlexSuper _ name ->
102 D.fromName name
104 RigidVar name ->
105 D.fromName name
107 RigidSuper _ name ->
108 D.fromName name
110 Type home name args ->
111 RT.apply ctx
112 (nameToDoc localizer home name)
113 (map (toDoc localizer RT.App) args)
115 Record fields ext ->
116 RT.record (fieldsToDocs localizer fields) (extToDoc ext)
118 Unit ->
119 "()"
121 Tuple a b maybeC ->
122 RT.tuple
123 (toDoc localizer RT.None a)
124 (toDoc localizer RT.None b)
125 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
127 Alias home name args _ ->
128 aliasToDoc localizer ctx home name args
131aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Type)] -> D.Doc
132aliasToDoc localizer ctx home name args =
133 RT.apply ctx
134 (nameToDoc localizer home name)
135 (map (toDoc localizer RT.App . snd) args)
138fieldsToDocs :: L.Localizer -> Map.Map N.Name Type -> [(D.Doc, D.Doc)]
139fieldsToDocs localizer fields =
140 Map.foldrWithKey (addField localizer) [] fields
143addField :: L.Localizer -> N.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)]
144addField localizer fieldName fieldType docs =
145 let
146 f = D.fromName fieldName
147 t = toDoc localizer RT.None fieldType
148 in
149 (f,t) : docs
152extToDoc :: Extension -> Maybe D.Doc
153extToDoc ext =
154 case ext of
155 Closed -> Nothing
156 FlexOpen x -> Just (D.fromName x)
157 RigidOpen x -> Just (D.fromName x)
161-- DIFF
164data Diff a =
165 Diff a a Status
168data Status
169 = Similar
170 | Different (Bag.Bag Problem)
173data Problem
174 = IntFloat
175 | StringFromInt
176 | StringFromFloat
177 | StringToInt
178 | StringToFloat
179 | AnythingToBool
180 | AnythingFromMaybe
181 | AnythingToList
182 | MissingArgs Int
183 | ReturnMismatch
184 | BadFlexSuper Super N.Name Type
185 | BadRigidVar N.Name Type
186 | BadRigidSuper Super N.Name Type
187 | FieldTypo N.Name [N.Name]
190instance Functor Diff where
191 fmap func (Diff a b status) =
192 Diff (func a) (func b) status
195instance Applicative Diff where
196 pure a =
197 Diff a a Similar
199 (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
200 Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)
203merge :: Status -> Status -> Status
204merge status1 status2 =
205 case status1 of
206 Similar ->
207 status2
209 Different problems1 ->
210 case status2 of
211 Similar ->
212 status1
214 Different problems2 ->
215 Different (Bag.append problems1 problems2)
219-- COMPARISON
222toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
223toComparison localizer tipe1 tipe2 =
224 case toDiff localizer RT.None tipe1 tipe2 of
225 Diff doc1 doc2 Similar ->
226 (doc1, doc2, [])
228 Diff doc1 doc2 (Different problems) ->
229 (doc1, doc2, Bag.toList problems)
232toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
233toDiff localizer ctx tipe1 tipe2 =
234 case (tipe1, tipe2) of
235 (Unit , Unit ) -> same localizer ctx tipe1
236 (Error , Error ) -> same localizer ctx tipe1
237 (Infinite, Infinite) -> same localizer ctx tipe1
239 (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1
240 (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1
241 (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1
242 (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1
244 (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2
245 (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2
247 (Lambda a b cs, Lambda x y zs) ->
248 if length cs == length zs then
249 RT.lambda ctx
250 <$> toDiff localizer RT.Func a x
251 <*> toDiff localizer RT.Func b y
252 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
253 else
254 diffLambda localizer ctx a b cs x y zs
256 (Tuple a b Nothing, Tuple x y Nothing) ->
257 RT.tuple
258 <$> toDiff localizer RT.None a x
259 <*> toDiff localizer RT.None b y
260 <*> pure []
262 (Tuple a b (Just c), Tuple x y (Just z)) ->
263 RT.tuple
264 <$> toDiff localizer RT.None a x
265 <*> toDiff localizer RT.None b y
266 <*> ((:[]) <$> toDiff localizer RT.None c z)
268 (Record fields1 ext1, Record fields2 ext2) ->
269 diffRecord localizer fields1 ext1 fields2 ext2
271 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
272 RT.apply ctx (nameToDoc localizer home1 name1)
273 <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2)
275 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
276 RT.apply ctx (nameToDoc localizer home1 name1)
277 <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2))
279 -- start trying to find specific problems
281 (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
282 different
283 (RT.apply ctx (D.dullyellow (nameToDoc localizer home name)) [toDoc localizer RT.App t1])
284 (toDoc localizer ctx t2)
285 (Bag.one AnythingFromMaybe)
287 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->
288 different
289 (toDoc localizer ctx t1)
290 (RT.apply ctx (D.dullyellow (nameToDoc localizer home name)) [toDoc localizer RT.App t2])
291 (Bag.one AnythingToList)
293 (Alias home name args t1, t2) ->
294 case diffAliasedRecord localizer t1 t2 of
295 Just (Diff _ doc2 status) ->
296 Diff (D.dullyellow (aliasToDoc localizer ctx home name args)) doc2 status
298 Nothing ->
299 different
300 (D.dullyellow (toDoc localizer ctx tipe1))
301 (D.dullyellow (toDoc localizer ctx tipe2))
302 Bag.empty
304 (t1, Alias home name args t2) ->
305 case diffAliasedRecord localizer t1 t2 of
306 Just (Diff doc1 _ status) ->
307 Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home name args)) status
309 Nothing ->
310 different
311 (D.dullyellow (toDoc localizer ctx tipe1))
312 (D.dullyellow (toDoc localizer ctx tipe2))
313 Bag.empty
315 pair ->
316 let
317 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
318 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
319 in
320 different doc1 doc2 $
321 case pair of
322 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
323 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
324 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
325 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
326 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
327 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
329 (Type home1 name1 [], Type home2 name2 [])
330 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
331 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
332 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
333 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
334 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
335 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
336 | isBool home2 name2 -> Bag.one AnythingToBool
338 (_, _) ->
339 Bag.empty
343-- DIFF HELPERS
346same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
347same localizer ctx tipe =
348 let
349 doc = toDoc localizer ctx tipe
350 in
351 Diff doc doc Similar
354similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
355similar localizer ctx t1 t2 =
356 Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar
359different :: a -> a -> Bag.Bag Problem -> Diff a
360different a b problems =
361 Diff a b (Different problems)
364isSimilar :: Diff a -> Bool
365isSimilar (Diff _ _ status) =
366 case status of
367 Similar -> True
368 Different _ -> False
372-- IS TYPE?
375isBool :: ModuleName.Canonical -> N.Name -> Bool
376isBool home name =
377 home == ModuleName.basics && name == N.bool
380isInt :: ModuleName.Canonical -> N.Name -> Bool
381isInt home name =
382 home == ModuleName.basics && name == N.int
385isFloat :: ModuleName.Canonical -> N.Name -> Bool
386isFloat home name =
387 home == ModuleName.basics && name == N.float
390isString :: ModuleName.Canonical -> N.Name -> Bool
391isString home name =
392 home == ModuleName.string && name == N.string
395isChar :: ModuleName.Canonical -> N.Name -> Bool
396isChar home name =
397 home == ModuleName.char && name == N.char
400isMaybe :: ModuleName.Canonical -> N.Name -> Bool
401isMaybe home name =
402 home == ModuleName.maybe && name == N.maybe
405isList :: ModuleName.Canonical -> N.Name -> Bool
406isList home name =
407 home == ModuleName.list && name == N.list
411-- DIFF ALIASED RECORD
414diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
415diffAliasedRecord localizer t1 t2 =
416 case (iteratedDealias t1, iteratedDealias t2) of
417 (Record fields1 ext1, Record fields2 ext2) ->
418 Just (diffRecord localizer fields1 ext1 fields2 ext2)
420 _ ->
421 Nothing
425-- DIFF LAMBDAS
428--
429-- INVARIANTS:
430-- length cs1 /= length cs2
431--
432diffLambda :: L.Localizer -> RT.Context -> Type -> Type -> [Type] -> Type -> Type -> [Type] -> Diff D.Doc
433diffLambda localizer ctx a1 b1 cs1 a2 b2 cs2 =
434 let
435 (result1:revArgs1) = reverse (a1:b1:cs1)
436 (result2:revArgs2) = reverse (a2:b2:cs2)
438 numArgs1 = length revArgs1
439 numArgs2 = length revArgs2
440 in
441 case toDiff localizer RT.Func result1 result2 of
442 Diff resultDoc1 resultDoc2 Similar ->
443 if numArgs1 < numArgs2 then
444 diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2
446 else
447 diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1
449 Diff resultDoc1 resultDoc2 (Different problems) ->
450 let
451 (a:b:cs) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)
452 (x:y:zs) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)
453 in
454 different
455 (D.dullyellow (RT.lambda ctx a b cs))
456 (D.dullyellow (RT.lambda ctx x y zs))
457 (Bag.append problems (Bag.one ReturnMismatch))
460--
461-- INVARIANTS:
462-- length shortRevArgs >= 2
463-- length longRevArgs >= 2
464-- length shortRevArgs < length longRevArgs
465--
466diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc
467diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
468 let
469 (a:b:cs, x:y:zs) =
470 case toGreedyMatch localizer shortRevArgs longRevArgs of
471 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
472 ( reverse (shortResult:shortRevArgDocs)
473 , reverse (longResult:longRevArgDocs)
474 )
476 Nothing ->
477 case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of
478 Just (GreedyMatch shortArgDocs longArgDocs) ->
479 ( shortArgDocs ++ [shortResult]
480 , longArgDocs ++ [longResult]
481 )
483 Nothing ->
484 let
485 toYellowDoc tipe =
486 D.dullyellow (toDoc localizer RT.Func tipe)
487 in
488 ( reverse (shortResult : map toYellowDoc shortRevArgs)
489 , reverse (longResult : map toYellowDoc longRevArgs )
490 )
491 in
492 different
493 (RT.lambda ctx a b cs)
494 (RT.lambda ctx x y zs)
495 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
499-- GREEDY ARG MATCHER
502data GreedyMatch =
503 GreedyMatch [D.Doc] [D.Doc]
506--
507-- INVARIANTS:
508-- length shorterArgs < length longerArgs
509--
510toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
511toGreedyMatch localizer shorterArgs longerArgs =
512 toGreedyMatchHelp localizer shorterArgs longerArgs (GreedyMatch [] [])
515toGreedyMatchHelp :: L.Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
516toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
517 let
518 toYellowDoc tipe =
519 D.dullyellow (toDoc localizer RT.Func tipe)
520 in
521 case (shorterArgs, longerArgs) of
522 (x:xs, y:ys) ->
523 case toDiff localizer RT.Func x y of
524 Diff a b Similar ->
525 toGreedyMatchHelp localizer xs ys $
526 GreedyMatch (a:shorterDocs) (b:longerDocs)
528 Diff _ _ (Different _) ->
529 toGreedyMatchHelp localizer shorterArgs ys $
530 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
532 ([], []) ->
533 Just match
535 ([], _:_) ->
536 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
538 (_:_, []) ->
539 Nothing
543-- RECORD DIFFS
546diffRecord :: L.Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff D.Doc
547diffRecord localizer fields1 ext1 fields2 ext2 =
548 let
549 toUnknownDocs field tipe =
550 ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )
552 toOverlapDocs field t1 t2 =
553 (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
555 left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
556 both = Map.intersectionWithKey toOverlapDocs fields1 fields2
557 right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)
559 fieldsDiff =
560 Map.elems <$>
561 if Map.null left && Map.null right then
562 sequenceA both
563 else
564 Map.union
565 <$> sequenceA both
566 <*> Diff left right (Different Bag.empty)
568 (Diff doc1 doc2 status) =
569 RT.record
570 <$> fieldsDiff
571 <*> extToDiff ext1 ext2
572 in
573 Diff doc1 doc2 $ merge status $
574 case (hasFixedFields ext1, hasFixedFields ext2) of
575 (True, True) ->
576 case Map.lookupMin left of
577 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
578 Nothing ->
579 case Map.lookupMin right of
580 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
581 Nothing -> Similar
583 (False, True) ->
584 case Map.lookupMin left of
585 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
586 Nothing -> Similar
588 (True, False) ->
589 case Map.lookupMin right of
590 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
591 Nothing -> Similar
593 (False, False) ->
594 Similar
597hasFixedFields :: Extension -> Bool
598hasFixedFields ext =
599 case ext of
600 Closed -> True
601 FlexOpen _ -> False
602 RigidOpen _ -> True
606-- DIFF RECORD EXTENSION
609extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
610extToDiff ext1 ext2 =
611 let
612 status = extToStatus ext1 ext2
613 extDoc1 = extToDoc ext1
614 extDoc2 = extToDoc ext2
615 in
616 case status of
617 Similar ->
618 Diff extDoc1 extDoc2 status
620 Different _ ->
621 Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
624extToStatus :: Extension -> Extension -> Status
625extToStatus ext1 ext2 =
626 case ext1 of
627 Closed ->
628 case ext2 of
629 Closed -> Similar
630 FlexOpen _ -> Similar
631 RigidOpen _ -> Different Bag.empty
633 FlexOpen _ ->
634 Similar
636 RigidOpen x ->
637 case ext2 of
638 Closed -> Different Bag.empty
639 FlexOpen _ -> Similar
640 RigidOpen y ->
641 if x == y
642 then Similar
643 else Different $ Bag.one $ BadRigidVar x (RigidVar y)