git.iko.soy/elk
on 1238607 help sign in
elk/compiler/src/Type/Error.hs
698 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 , Direction(..)
11 , toComparison
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 ((<>))
24import qualified Data.Name as Name
26import qualified Data.Bag as Bag
27import qualified Elm.ModuleName as ModuleName
28import qualified Reporting.Doc as D
29import qualified Reporting.Render.Type as RT
30import qualified Reporting.Render.Type.Localizer as L
34-- ERROR TYPES
37data Type
38 = Lambda Type Type [Type]
39 | Infinite
40 | Error
41 | FlexVar Name.Name
42 | FlexSuper Super Name.Name
43 | RigidVar Name.Name
44 | RigidSuper Super Name.Name
45 | Type ModuleName.Canonical Name.Name [Type]
46 | Record (Map.Map Name.Name Type) Extension
47 | Unit
48 | Tuple Type Type (Maybe Type)
49 | Alias ModuleName.Canonical Name.Name [(Name.Name, Type)] Type
52data Super
53 = Number
54 | Comparable
55 | Appendable
56 | CompAppend
57 deriving (Eq)
60data Extension
61 = Closed
62 | FlexOpen Name.Name
63 | RigidOpen Name.Name
66iteratedDealias :: Type -> Type
67iteratedDealias tipe =
68 case tipe of
69 Alias _ _ _ real ->
70 iteratedDealias real
72 _ ->
73 tipe
77-- TO DOC
80toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
81toDoc localizer ctx tipe =
82 case tipe of
83 Lambda a b cs ->
84 RT.lambda ctx
85 (toDoc localizer RT.Func a)
86 (toDoc localizer RT.Func b)
87 (map (toDoc localizer RT.Func) cs)
89 Infinite ->
90 "∞"
92 Error ->
93 "?"
95 FlexVar name ->
96 D.fromName name
98 FlexSuper _ name ->
99 D.fromName name
101 RigidVar name ->
102 D.fromName name
104 RigidSuper _ name ->
105 D.fromName name
107 Type home name args ->
108 RT.apply ctx
109 (L.toDoc localizer home name)
110 (map (toDoc localizer RT.App) args)
112 Record fields ext ->
113 RT.record (fieldsToDocs localizer fields) (extToDoc ext)
115 Unit ->
116 "()"
118 Tuple a b maybeC ->
119 RT.tuple
120 (toDoc localizer RT.None a)
121 (toDoc localizer RT.None b)
122 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
124 Alias home name args _ ->
125 aliasToDoc localizer ctx home name args
128aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Type)] -> D.Doc
129aliasToDoc localizer ctx home name args =
130 RT.apply ctx
131 (L.toDoc localizer home name)
132 (map (toDoc localizer RT.App . snd) args)
135fieldsToDocs :: L.Localizer -> Map.Map Name.Name Type -> [(D.Doc, D.Doc)]
136fieldsToDocs localizer fields =
137 Map.foldrWithKey (addField localizer) [] fields
140addField :: L.Localizer -> Name.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)]
141addField localizer fieldName fieldType docs =
142 let
143 f = D.fromName fieldName
144 t = toDoc localizer RT.None fieldType
145 in
146 (f,t) : docs
149extToDoc :: Extension -> Maybe D.Doc
150extToDoc ext =
151 case ext of
152 Closed -> Nothing
153 FlexOpen x -> Just (D.fromName x)
154 RigidOpen x -> Just (D.fromName x)
158-- DIFF
161data Diff a =
162 Diff a a Status
165data Status
166 = Similar
167 | Different (Bag.Bag Problem)
170data Problem
171 = IntFloat
172 | StringFromInt
173 | StringFromFloat
174 | StringToInt
175 | StringToFloat
176 | AnythingToBool
177 | AnythingFromMaybe
178 | AnythingToList
179 | MissingArgs Int
180 | ReturnMismatch
181 | BadFlexSuper Direction Super Name.Name Type
182 | BadRigidVar Name.Name Type
183 | BadRigidSuper Super Name.Name Type
184 | FieldTypo Name.Name [Name.Name]
185 | FieldsMissing [Name.Name]
188data Direction = Have | Need
191instance Functor Diff where
192 fmap func (Diff a b status) =
193 Diff (func a) (func b) status
196instance Applicative Diff where
197 pure a =
198 Diff a a Similar
200 (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
201 Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)
204merge :: Status -> Status -> Status
205merge status1 status2 =
206 case status1 of
207 Similar ->
208 status2
210 Different problems1 ->
211 case status2 of
212 Similar ->
213 status1
215 Different problems2 ->
216 Different (Bag.append problems1 problems2)
220-- COMPARISON
223toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
224toComparison localizer tipe1 tipe2 =
225 case toDiff localizer RT.None tipe1 tipe2 of
226 Diff doc1 doc2 Similar ->
227 (doc1, doc2, [])
229 Diff doc1 doc2 (Different problems) ->
230 (doc1, doc2, Bag.toList problems)
233toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
234toDiff localizer ctx tipe1 tipe2 =
235 case (tipe1, tipe2) of
236 (Unit , Unit ) -> same localizer ctx tipe1
237 (Error , Error ) -> same localizer ctx tipe1
238 (Infinite, Infinite) -> same localizer ctx tipe1
240 (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1
241 (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1
242 (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1
243 (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1
245 (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2
246 (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2
248 (FlexSuper s _, t ) | isSuper s t -> similar localizer ctx tipe1 tipe2
249 (t , FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2
251 (Lambda a b cs, Lambda x y zs) ->
252 if length cs == length zs then
253 RT.lambda ctx
254 <$> toDiff localizer RT.Func a x
255 <*> toDiff localizer RT.Func b y
256 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
257 else
258 diffLambda localizer ctx a b cs x y zs
260 (Tuple a b Nothing, Tuple x y Nothing) ->
261 RT.tuple
262 <$> toDiff localizer RT.None a x
263 <*> toDiff localizer RT.None b y
264 <*> pure []
266 (Tuple a b (Just c), Tuple x y (Just z)) ->
267 RT.tuple
268 <$> toDiff localizer RT.None a x
269 <*> toDiff localizer RT.None b y
270 <*> ((:[]) <$> toDiff localizer RT.None c z)
272 (Record fields1 ext1, Record fields2 ext2) ->
273 diffRecord localizer fields1 ext1 fields2 ext2
275 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
276 RT.apply ctx (L.toDoc localizer home1 name1)
277 <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2)
279 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
280 RT.apply ctx (L.toDoc localizer home1 name1)
281 <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2))
283 -- start trying to find specific problems
285 (Type home1 name1 args1, Type home2 name2 args2) | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
286 different
287 (nameClashToDoc ctx localizer home1 name1 args1)
288 (nameClashToDoc ctx localizer home2 name2 args2)
289 Bag.empty
291 (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
292 different
293 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1])
294 (toDoc localizer ctx t2)
295 (Bag.one AnythingFromMaybe)
297 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->
298 different
299 (toDoc localizer ctx t1)
300 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
301 (Bag.one AnythingToList)
303 (Alias home1 name1 args1 t1, t2) ->
304 case diffAliasedRecord localizer t1 t2 of
305 Just (Diff _ doc2 status) ->
306 Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status
308 Nothing ->
309 case t2 of
310 Type home2 name2 args2 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
311 different
312 (nameClashToDoc ctx localizer home1 name1 (map snd args1))
313 (nameClashToDoc ctx localizer home2 name2 args2)
314 Bag.empty
316 _ ->
317 different
318 (D.dullyellow (toDoc localizer ctx tipe1))
319 (D.dullyellow (toDoc localizer ctx tipe2))
320 Bag.empty
322 (t1, Alias home2 name2 args2 t2) ->
323 case diffAliasedRecord localizer t1 t2 of
324 Just (Diff doc1 _ status) ->
325 Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status
327 Nothing ->
328 case t1 of
329 Type home1 name1 args1 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
330 different
331 (nameClashToDoc ctx localizer home1 name1 args1)
332 (nameClashToDoc ctx localizer home2 name2 (map snd args2))
333 Bag.empty
335 _ ->
336 different
337 (D.dullyellow (toDoc localizer ctx tipe1))
338 (D.dullyellow (toDoc localizer ctx tipe2))
339 Bag.empty
341 pair ->
342 let
343 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
344 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
345 in
346 different doc1 doc2 $
347 case pair of
348 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
349 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper Have s x other
350 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
351 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
352 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper Need s x other
353 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
355 (Type home1 name1 [], Type home2 name2 [])
356 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
357 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
358 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
359 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
360 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
361 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
362 | isBool home2 name2 -> Bag.one AnythingToBool
364 (_, _) ->
365 Bag.empty
369-- DIFF HELPERS
372same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
373same localizer ctx tipe =
374 let
375 doc = toDoc localizer ctx tipe
376 in
377 Diff doc doc Similar
380similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
381similar localizer ctx t1 t2 =
382 Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar
385different :: a -> a -> Bag.Bag Problem -> Diff a
386different a b problems =
387 Diff a b (Different problems)
390isSimilar :: Diff a -> Bool
391isSimilar (Diff _ _ status) =
392 case status of
393 Similar -> True
394 Different _ -> False
398-- IS TYPE?
401isBool :: ModuleName.Canonical -> Name.Name -> Bool
402isBool home name =
403 home == ModuleName.basics && name == Name.bool
406isInt :: ModuleName.Canonical -> Name.Name -> Bool
407isInt home name =
408 home == ModuleName.basics && name == Name.int
411isFloat :: ModuleName.Canonical -> Name.Name -> Bool
412isFloat home name =
413 home == ModuleName.basics && name == Name.float
416isString :: ModuleName.Canonical -> Name.Name -> Bool
417isString home name =
418 home == ModuleName.string && name == Name.string
421isChar :: ModuleName.Canonical -> Name.Name -> Bool
422isChar home name =
423 home == ModuleName.char && name == Name.char
426isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
427isMaybe home name =
428 home == ModuleName.maybe && name == Name.maybe
431isList :: ModuleName.Canonical -> Name.Name -> Bool
432isList home name =
433 home == ModuleName.list && name == Name.list
437-- IS SUPER?
440isSuper :: Super -> Type -> Bool
441isSuper super tipe =
442 case iteratedDealias tipe of
443 Type h n args ->
444 case super of
445 Number -> isInt h n || isFloat h n
446 Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args)
447 Appendable -> isString h n || isList h n
448 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
450 _ ->
451 False
455-- NAME CLASH
458nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> Name.Name -> [Type] -> D.Doc
459nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args =
460 RT.apply ctx
461 (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name))
462 (map (toDoc localizer RT.App) args)
466-- DIFF ALIASED RECORD
469diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
470diffAliasedRecord localizer t1 t2 =
471 case (iteratedDealias t1, iteratedDealias t2) of
472 (Record fields1 ext1, Record fields2 ext2) ->
473 Just (diffRecord localizer fields1 ext1 fields2 ext2)
475 _ ->
476 Nothing
480-- DIFF LAMBDAS
483--
484-- INVARIANTS:
485-- length cs1 /= length cs2
486--
487diffLambda :: L.Localizer -> RT.Context -> Type -> Type -> [Type] -> Type -> Type -> [Type] -> Diff D.Doc
488diffLambda localizer ctx a1 b1 cs1 a2 b2 cs2 =
489 let
490 (result1:revArgs1) = reverse (a1:b1:cs1)
491 (result2:revArgs2) = reverse (a2:b2:cs2)
493 numArgs1 = length revArgs1
494 numArgs2 = length revArgs2
495 in
496 case toDiff localizer RT.Func result1 result2 of
497 Diff resultDoc1 resultDoc2 Similar ->
498 if numArgs1 < numArgs2 then
499 diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2
501 else
502 diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1
504 Diff resultDoc1 resultDoc2 (Different problems) ->
505 let
506 (a:b:cs) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)
507 (x:y:zs) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)
508 in
509 different
510 (D.dullyellow (RT.lambda ctx a b cs))
511 (D.dullyellow (RT.lambda ctx x y zs))
512 (Bag.append problems (Bag.one ReturnMismatch))
515--
516-- INVARIANTS:
517-- length shortRevArgs >= 2
518-- length longRevArgs >= 2
519-- length shortRevArgs < length longRevArgs
520--
521diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc
522diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
523 let
524 (a:b:cs, x:y:zs) =
525 case toGreedyMatch localizer shortRevArgs longRevArgs of
526 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
527 ( reverse (shortResult:shortRevArgDocs)
528 , reverse (longResult:longRevArgDocs)
529 )
531 Nothing ->
532 case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of
533 Just (GreedyMatch shortArgDocs longArgDocs) ->
534 ( shortArgDocs ++ [shortResult]
535 , longArgDocs ++ [longResult]
536 )
538 Nothing ->
539 let
540 toYellowDoc tipe =
541 D.dullyellow (toDoc localizer RT.Func tipe)
542 in
543 ( reverse (shortResult : map toYellowDoc shortRevArgs)
544 , reverse (longResult : map toYellowDoc longRevArgs )
545 )
546 in
547 different
548 (RT.lambda ctx a b cs)
549 (RT.lambda ctx x y zs)
550 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
554-- GREEDY ARG MATCHER
557data GreedyMatch =
558 GreedyMatch [D.Doc] [D.Doc]
561--
562-- INVARIANTS:
563-- length shorterArgs < length longerArgs
564--
565toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
566toGreedyMatch localizer shorterArgs longerArgs =
567 toGreedyMatchHelp localizer shorterArgs longerArgs (GreedyMatch [] [])
570toGreedyMatchHelp :: L.Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
571toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
572 let
573 toYellowDoc tipe =
574 D.dullyellow (toDoc localizer RT.Func tipe)
575 in
576 case (shorterArgs, longerArgs) of
577 (x:xs, y:ys) ->
578 case toDiff localizer RT.Func x y of
579 Diff a b Similar ->
580 toGreedyMatchHelp localizer xs ys $
581 GreedyMatch (a:shorterDocs) (b:longerDocs)
583 Diff _ _ (Different _) ->
584 toGreedyMatchHelp localizer shorterArgs ys $
585 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
587 ([], []) ->
588 Just match
590 ([], _:_) ->
591 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
593 (_:_, []) ->
594 Nothing
598-- RECORD DIFFS
601diffRecord :: L.Localizer -> Map.Map Name.Name Type -> Extension -> Map.Map Name.Name Type -> Extension -> Diff D.Doc
602diffRecord localizer fields1 ext1 fields2 ext2 =
603 let
604 toUnknownDocs field tipe =
605 ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )
607 toOverlapDocs field t1 t2 =
608 (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
610 left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
611 both = Map.intersectionWithKey toOverlapDocs fields1 fields2
612 right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)
614 fieldsDiff =
615 Map.elems <$>
616 if Map.null left && Map.null right then
617 sequenceA both
618 else
619 Map.union
620 <$> sequenceA both
621 <*> Diff left right (Different Bag.empty)
623 (Diff doc1 doc2 status) =
624 RT.record
625 <$> fieldsDiff
626 <*> extToDiff ext1 ext2
627 in
628 Diff doc1 doc2 $ merge status $
629 case (hasFixedFields ext1, hasFixedFields ext2) of
630 (True, True) ->
631 case Map.lookupMin left of
632 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
633 Nothing ->
634 if Map.null right
635 then Similar
636 else Different $ Bag.one $ FieldsMissing (Map.keys right)
638 (False, True) ->
639 case Map.lookupMin left of
640 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
641 Nothing -> Similar
643 (True, False) ->
644 case Map.lookupMin right of
645 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
646 Nothing -> Similar
648 (False, False) ->
649 Similar
652hasFixedFields :: Extension -> Bool
653hasFixedFields ext =
654 case ext of
655 Closed -> True
656 FlexOpen _ -> False
657 RigidOpen _ -> True
661-- DIFF RECORD EXTENSION
664extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
665extToDiff ext1 ext2 =
666 let
667 status = extToStatus ext1 ext2
668 extDoc1 = extToDoc ext1
669 extDoc2 = extToDoc ext2
670 in
671 case status of
672 Similar ->
673 Diff extDoc1 extDoc2 status
675 Different _ ->
676 Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
679extToStatus :: Extension -> Extension -> Status
680extToStatus ext1 ext2 =
681 case ext1 of
682 Closed ->
683 case ext2 of
684 Closed -> Similar
685 FlexOpen _ -> Similar
686 RigidOpen _ -> Different Bag.empty
688 FlexOpen _ ->
689 Similar
691 RigidOpen x ->
692 case ext2 of
693 Closed -> Different Bag.empty
694 FlexOpen _ -> Similar
695 RigidOpen y ->
696 if x == y
697 then Similar
698 else Different $ Bag.one $ BadRigidVar x (RigidVar y)