git.iko.soy/elk
on 0641ad2 help sign in
elk/compiler/src/Type/Error.hs
694 lines 19 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
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.Doc as D
28import qualified Reporting.Render.Type as RT
29import qualified Reporting.Render.Type.Localizer as L
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
56 deriving (Eq)
59data Extension
60 = Closed
61 | FlexOpen N.Name
62 | RigidOpen N.Name
65iteratedDealias :: Type -> Type
66iteratedDealias tipe =
67 case tipe of
68 Alias _ _ _ real ->
69 iteratedDealias real
71 _ ->
72 tipe
76-- TO DOC
79toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
80toDoc localizer ctx tipe =
81 case tipe of
82 Lambda a b cs ->
83 RT.lambda ctx
84 (toDoc localizer RT.Func a)
85 (toDoc localizer RT.Func b)
86 (map (toDoc localizer RT.Func) cs)
88 Infinite ->
89 "∞"
91 Error ->
92 "?"
94 FlexVar name ->
95 D.fromName name
97 FlexSuper _ name ->
98 D.fromName name
100 RigidVar name ->
101 D.fromName name
103 RigidSuper _ name ->
104 D.fromName name
106 Type home name args ->
107 RT.apply ctx
108 (L.toDoc localizer home name)
109 (map (toDoc localizer RT.App) args)
111 Record fields ext ->
112 RT.record (fieldsToDocs localizer fields) (extToDoc ext)
114 Unit ->
115 "()"
117 Tuple a b maybeC ->
118 RT.tuple
119 (toDoc localizer RT.None a)
120 (toDoc localizer RT.None b)
121 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
123 Alias home name args _ ->
124 aliasToDoc localizer ctx home name args
127aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Type)] -> D.Doc
128aliasToDoc localizer ctx home name args =
129 RT.apply ctx
130 (L.toDoc localizer home name)
131 (map (toDoc localizer RT.App . snd) args)
134fieldsToDocs :: L.Localizer -> Map.Map N.Name Type -> [(D.Doc, D.Doc)]
135fieldsToDocs localizer fields =
136 Map.foldrWithKey (addField localizer) [] fields
139addField :: L.Localizer -> N.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)]
140addField localizer fieldName fieldType docs =
141 let
142 f = D.fromName fieldName
143 t = toDoc localizer RT.None fieldType
144 in
145 (f,t) : docs
148extToDoc :: Extension -> Maybe D.Doc
149extToDoc ext =
150 case ext of
151 Closed -> Nothing
152 FlexOpen x -> Just (D.fromName x)
153 RigidOpen x -> Just (D.fromName x)
157-- DIFF
160data Diff a =
161 Diff a a Status
164data Status
165 = Similar
166 | Different (Bag.Bag Problem)
169data Problem
170 = IntFloat
171 | StringFromInt
172 | StringFromFloat
173 | StringToInt
174 | StringToFloat
175 | AnythingToBool
176 | AnythingFromMaybe
177 | AnythingToList
178 | MissingArgs Int
179 | ReturnMismatch
180 | BadFlexSuper Super N.Name Type
181 | BadRigidVar N.Name Type
182 | BadRigidSuper Super N.Name Type
183 | FieldTypo N.Name [N.Name]
184 | FieldsMissing [N.Name]
187instance Functor Diff where
188 fmap func (Diff a b status) =
189 Diff (func a) (func b) status
192instance Applicative Diff where
193 pure a =
194 Diff a a Similar
196 (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
197 Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)
200merge :: Status -> Status -> Status
201merge status1 status2 =
202 case status1 of
203 Similar ->
204 status2
206 Different problems1 ->
207 case status2 of
208 Similar ->
209 status1
211 Different problems2 ->
212 Different (Bag.append problems1 problems2)
216-- COMPARISON
219toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
220toComparison localizer tipe1 tipe2 =
221 case toDiff localizer RT.None tipe1 tipe2 of
222 Diff doc1 doc2 Similar ->
223 (doc1, doc2, [])
225 Diff doc1 doc2 (Different problems) ->
226 (doc1, doc2, Bag.toList problems)
229toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
230toDiff localizer ctx tipe1 tipe2 =
231 case (tipe1, tipe2) of
232 (Unit , Unit ) -> same localizer ctx tipe1
233 (Error , Error ) -> same localizer ctx tipe1
234 (Infinite, Infinite) -> same localizer ctx tipe1
236 (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1
237 (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1
238 (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1
239 (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1
241 (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2
242 (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2
244 (FlexSuper s _, t ) | isSuper s t -> similar localizer ctx tipe1 tipe2
245 (t , FlexSuper s _) | isSuper s t -> 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 (L.toDoc 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 (L.toDoc 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 home1 name1 args1, Type home2 name2 args2) | L.toString localizer home1 name1 == L.toString localizer home2 name2 ->
282 different
283 (nameClashToDoc ctx localizer home1 name1 args1)
284 (nameClashToDoc ctx localizer home2 name2 args2)
285 Bag.empty
287 (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
288 different
289 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1])
290 (toDoc localizer ctx t2)
291 (Bag.one AnythingFromMaybe)
293 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->
294 different
295 (toDoc localizer ctx t1)
296 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
297 (Bag.one AnythingToList)
299 (Alias home1 name1 args1 t1, t2) ->
300 case diffAliasedRecord localizer t1 t2 of
301 Just (Diff _ doc2 status) ->
302 Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status
304 Nothing ->
305 case t2 of
306 Type home2 name2 args2 | L.toString localizer home1 name1 == L.toString localizer home2 name2 ->
307 different
308 (nameClashToDoc ctx localizer home1 name1 (map snd args1))
309 (nameClashToDoc ctx localizer home2 name2 args2)
310 Bag.empty
312 _ ->
313 different
314 (D.dullyellow (toDoc localizer ctx tipe1))
315 (D.dullyellow (toDoc localizer ctx tipe2))
316 Bag.empty
318 (t1, Alias home2 name2 args2 t2) ->
319 case diffAliasedRecord localizer t1 t2 of
320 Just (Diff doc1 _ status) ->
321 Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status
323 Nothing ->
324 case t1 of
325 Type home1 name1 args1 | L.toString localizer home1 name1 == L.toString localizer home2 name2 ->
326 different
327 (nameClashToDoc ctx localizer home1 name1 args1)
328 (nameClashToDoc ctx localizer home2 name2 (map snd args2))
329 Bag.empty
331 _ ->
332 different
333 (D.dullyellow (toDoc localizer ctx tipe1))
334 (D.dullyellow (toDoc localizer ctx tipe2))
335 Bag.empty
337 pair ->
338 let
339 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
340 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
341 in
342 different doc1 doc2 $
343 case pair of
344 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
345 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
346 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
347 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
348 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
349 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
351 (Type home1 name1 [], Type home2 name2 [])
352 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
353 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
354 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
355 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
356 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
357 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
358 | isBool home2 name2 -> Bag.one AnythingToBool
360 (_, _) ->
361 Bag.empty
365-- DIFF HELPERS
368same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
369same localizer ctx tipe =
370 let
371 doc = toDoc localizer ctx tipe
372 in
373 Diff doc doc Similar
376similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
377similar localizer ctx t1 t2 =
378 Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar
381different :: a -> a -> Bag.Bag Problem -> Diff a
382different a b problems =
383 Diff a b (Different problems)
386isSimilar :: Diff a -> Bool
387isSimilar (Diff _ _ status) =
388 case status of
389 Similar -> True
390 Different _ -> False
394-- IS TYPE?
397isBool :: ModuleName.Canonical -> N.Name -> Bool
398isBool home name =
399 home == ModuleName.basics && name == N.bool
402isInt :: ModuleName.Canonical -> N.Name -> Bool
403isInt home name =
404 home == ModuleName.basics && name == N.int
407isFloat :: ModuleName.Canonical -> N.Name -> Bool
408isFloat home name =
409 home == ModuleName.basics && name == N.float
412isString :: ModuleName.Canonical -> N.Name -> Bool
413isString home name =
414 home == ModuleName.string && name == N.string
417isChar :: ModuleName.Canonical -> N.Name -> Bool
418isChar home name =
419 home == ModuleName.char && name == N.char
422isMaybe :: ModuleName.Canonical -> N.Name -> Bool
423isMaybe home name =
424 home == ModuleName.maybe && name == N.maybe
427isList :: ModuleName.Canonical -> N.Name -> Bool
428isList home name =
429 home == ModuleName.list && name == N.list
433-- IS SUPER?
436isSuper :: Super -> Type -> Bool
437isSuper super tipe =
438 case iteratedDealias tipe of
439 Type h n args ->
440 case super of
441 Number -> isInt h n || isFloat h n
442 Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args)
443 Appendable -> isString h n || isList h n
444 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
446 _ ->
447 False
451-- NAME CLASH
454nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> N.Name -> [Type] -> D.Doc
455nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args =
456 RT.apply ctx
457 (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name))
458 (map (toDoc localizer RT.App) args)
462-- DIFF ALIASED RECORD
465diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
466diffAliasedRecord localizer t1 t2 =
467 case (iteratedDealias t1, iteratedDealias t2) of
468 (Record fields1 ext1, Record fields2 ext2) ->
469 Just (diffRecord localizer fields1 ext1 fields2 ext2)
471 _ ->
472 Nothing
476-- DIFF LAMBDAS
479--
480-- INVARIANTS:
481-- length cs1 /= length cs2
482--
483diffLambda :: L.Localizer -> RT.Context -> Type -> Type -> [Type] -> Type -> Type -> [Type] -> Diff D.Doc
484diffLambda localizer ctx a1 b1 cs1 a2 b2 cs2 =
485 let
486 (result1:revArgs1) = reverse (a1:b1:cs1)
487 (result2:revArgs2) = reverse (a2:b2:cs2)
489 numArgs1 = length revArgs1
490 numArgs2 = length revArgs2
491 in
492 case toDiff localizer RT.Func result1 result2 of
493 Diff resultDoc1 resultDoc2 Similar ->
494 if numArgs1 < numArgs2 then
495 diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2
497 else
498 diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1
500 Diff resultDoc1 resultDoc2 (Different problems) ->
501 let
502 (a:b:cs) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)
503 (x:y:zs) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)
504 in
505 different
506 (D.dullyellow (RT.lambda ctx a b cs))
507 (D.dullyellow (RT.lambda ctx x y zs))
508 (Bag.append problems (Bag.one ReturnMismatch))
511--
512-- INVARIANTS:
513-- length shortRevArgs >= 2
514-- length longRevArgs >= 2
515-- length shortRevArgs < length longRevArgs
516--
517diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc
518diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
519 let
520 (a:b:cs, x:y:zs) =
521 case toGreedyMatch localizer shortRevArgs longRevArgs of
522 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
523 ( reverse (shortResult:shortRevArgDocs)
524 , reverse (longResult:longRevArgDocs)
525 )
527 Nothing ->
528 case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of
529 Just (GreedyMatch shortArgDocs longArgDocs) ->
530 ( shortArgDocs ++ [shortResult]
531 , longArgDocs ++ [longResult]
532 )
534 Nothing ->
535 let
536 toYellowDoc tipe =
537 D.dullyellow (toDoc localizer RT.Func tipe)
538 in
539 ( reverse (shortResult : map toYellowDoc shortRevArgs)
540 , reverse (longResult : map toYellowDoc longRevArgs )
541 )
542 in
543 different
544 (RT.lambda ctx a b cs)
545 (RT.lambda ctx x y zs)
546 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
550-- GREEDY ARG MATCHER
553data GreedyMatch =
554 GreedyMatch [D.Doc] [D.Doc]
557--
558-- INVARIANTS:
559-- length shorterArgs < length longerArgs
560--
561toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
562toGreedyMatch localizer shorterArgs longerArgs =
563 toGreedyMatchHelp localizer shorterArgs longerArgs (GreedyMatch [] [])
566toGreedyMatchHelp :: L.Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
567toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
568 let
569 toYellowDoc tipe =
570 D.dullyellow (toDoc localizer RT.Func tipe)
571 in
572 case (shorterArgs, longerArgs) of
573 (x:xs, y:ys) ->
574 case toDiff localizer RT.Func x y of
575 Diff a b Similar ->
576 toGreedyMatchHelp localizer xs ys $
577 GreedyMatch (a:shorterDocs) (b:longerDocs)
579 Diff _ _ (Different _) ->
580 toGreedyMatchHelp localizer shorterArgs ys $
581 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
583 ([], []) ->
584 Just match
586 ([], _:_) ->
587 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
589 (_:_, []) ->
590 Nothing
594-- RECORD DIFFS
597diffRecord :: L.Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff D.Doc
598diffRecord localizer fields1 ext1 fields2 ext2 =
599 let
600 toUnknownDocs field tipe =
601 ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )
603 toOverlapDocs field t1 t2 =
604 (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
606 left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
607 both = Map.intersectionWithKey toOverlapDocs fields1 fields2
608 right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)
610 fieldsDiff =
611 Map.elems <$>
612 if Map.null left && Map.null right then
613 sequenceA both
614 else
615 Map.union
616 <$> sequenceA both
617 <*> Diff left right (Different Bag.empty)
619 (Diff doc1 doc2 status) =
620 RT.record
621 <$> fieldsDiff
622 <*> extToDiff ext1 ext2
623 in
624 Diff doc1 doc2 $ merge status $
625 case (hasFixedFields ext1, hasFixedFields ext2) of
626 (True, True) ->
627 case Map.lookupMin left of
628 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
629 Nothing ->
630 if Map.null right
631 then Similar
632 else Different $ Bag.one $ FieldsMissing (Map.keys right)
634 (False, True) ->
635 case Map.lookupMin left of
636 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
637 Nothing -> Similar
639 (True, False) ->
640 case Map.lookupMin right of
641 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
642 Nothing -> Similar
644 (False, False) ->
645 Similar
648hasFixedFields :: Extension -> Bool
649hasFixedFields ext =
650 case ext of
651 Closed -> True
652 FlexOpen _ -> False
653 RigidOpen _ -> True
657-- DIFF RECORD EXTENSION
660extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
661extToDiff ext1 ext2 =
662 let
663 status = extToStatus ext1 ext2
664 extDoc1 = extToDoc ext1
665 extDoc2 = extToDoc ext2
666 in
667 case status of
668 Similar ->
669 Diff extDoc1 extDoc2 status
671 Different _ ->
672 Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
675extToStatus :: Extension -> Extension -> Status
676extToStatus ext1 ext2 =
677 case ext1 of
678 Closed ->
679 case ext2 of
680 Closed -> Similar
681 FlexOpen _ -> Similar
682 RigidOpen _ -> Different Bag.empty
684 FlexOpen _ ->
685 Similar
687 RigidOpen x ->
688 case ext2 of
689 Closed -> Different Bag.empty
690 FlexOpen _ -> Similar
691 RigidOpen y ->
692 if x == y
693 then Similar
694 else Different $ Bag.one $ BadRigidVar x (RigidVar y)