git.iko.soy/elk
on d88abc7 help sign in
elk/compiler/src/Type/Error.hs
665 lines 18 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]
188 | FieldsMissing [N.Name]
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 (nameToDoc 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 (nameToDoc 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 home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
286 different
287 (RT.apply ctx (D.dullyellow (nameToDoc localizer home name)) [toDoc localizer RT.App t1])
288 (toDoc localizer ctx t2)
289 (Bag.one AnythingFromMaybe)
291 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->
292 different
293 (toDoc localizer ctx t1)
294 (RT.apply ctx (D.dullyellow (nameToDoc localizer home name)) [toDoc localizer RT.App t2])
295 (Bag.one AnythingToList)
297 (Alias home name args t1, t2) ->
298 case diffAliasedRecord localizer t1 t2 of
299 Just (Diff _ doc2 status) ->
300 Diff (D.dullyellow (aliasToDoc localizer ctx home name args)) doc2 status
302 Nothing ->
303 different
304 (D.dullyellow (toDoc localizer ctx tipe1))
305 (D.dullyellow (toDoc localizer ctx tipe2))
306 Bag.empty
308 (t1, Alias home name args t2) ->
309 case diffAliasedRecord localizer t1 t2 of
310 Just (Diff doc1 _ status) ->
311 Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home name args)) status
313 Nothing ->
314 different
315 (D.dullyellow (toDoc localizer ctx tipe1))
316 (D.dullyellow (toDoc localizer ctx tipe2))
317 Bag.empty
319 pair ->
320 let
321 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
322 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
323 in
324 different doc1 doc2 $
325 case pair of
326 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
327 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
328 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
329 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
330 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
331 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
333 (Type home1 name1 [], Type home2 name2 [])
334 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
335 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
336 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
337 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
338 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
339 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
340 | isBool home2 name2 -> Bag.one AnythingToBool
342 (_, _) ->
343 Bag.empty
347-- DIFF HELPERS
350same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
351same localizer ctx tipe =
352 let
353 doc = toDoc localizer ctx tipe
354 in
355 Diff doc doc Similar
358similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
359similar localizer ctx t1 t2 =
360 Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar
363different :: a -> a -> Bag.Bag Problem -> Diff a
364different a b problems =
365 Diff a b (Different problems)
368isSimilar :: Diff a -> Bool
369isSimilar (Diff _ _ status) =
370 case status of
371 Similar -> True
372 Different _ -> False
376-- IS TYPE?
379isBool :: ModuleName.Canonical -> N.Name -> Bool
380isBool home name =
381 home == ModuleName.basics && name == N.bool
384isInt :: ModuleName.Canonical -> N.Name -> Bool
385isInt home name =
386 home == ModuleName.basics && name == N.int
389isFloat :: ModuleName.Canonical -> N.Name -> Bool
390isFloat home name =
391 home == ModuleName.basics && name == N.float
394isString :: ModuleName.Canonical -> N.Name -> Bool
395isString home name =
396 home == ModuleName.string && name == N.string
399isChar :: ModuleName.Canonical -> N.Name -> Bool
400isChar home name =
401 home == ModuleName.char && name == N.char
404isMaybe :: ModuleName.Canonical -> N.Name -> Bool
405isMaybe home name =
406 home == ModuleName.maybe && name == N.maybe
409isList :: ModuleName.Canonical -> N.Name -> Bool
410isList home name =
411 home == ModuleName.list && name == N.list
415-- IS SUPER?
418isSuper :: Super -> Type -> Bool
419isSuper super tipe =
420 case iteratedDealias tipe of
421 Type h n args ->
422 case super of
423 Number -> isInt h n || isFloat h n
424 Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args)
425 Appendable -> isString h n || isList h n
426 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
428 _ ->
429 False
433-- DIFF ALIASED RECORD
436diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
437diffAliasedRecord localizer t1 t2 =
438 case (iteratedDealias t1, iteratedDealias t2) of
439 (Record fields1 ext1, Record fields2 ext2) ->
440 Just (diffRecord localizer fields1 ext1 fields2 ext2)
442 _ ->
443 Nothing
447-- DIFF LAMBDAS
450--
451-- INVARIANTS:
452-- length cs1 /= length cs2
453--
454diffLambda :: L.Localizer -> RT.Context -> Type -> Type -> [Type] -> Type -> Type -> [Type] -> Diff D.Doc
455diffLambda localizer ctx a1 b1 cs1 a2 b2 cs2 =
456 let
457 (result1:revArgs1) = reverse (a1:b1:cs1)
458 (result2:revArgs2) = reverse (a2:b2:cs2)
460 numArgs1 = length revArgs1
461 numArgs2 = length revArgs2
462 in
463 case toDiff localizer RT.Func result1 result2 of
464 Diff resultDoc1 resultDoc2 Similar ->
465 if numArgs1 < numArgs2 then
466 diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2
468 else
469 diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1
471 Diff resultDoc1 resultDoc2 (Different problems) ->
472 let
473 (a:b:cs) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)
474 (x:y:zs) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)
475 in
476 different
477 (D.dullyellow (RT.lambda ctx a b cs))
478 (D.dullyellow (RT.lambda ctx x y zs))
479 (Bag.append problems (Bag.one ReturnMismatch))
482--
483-- INVARIANTS:
484-- length shortRevArgs >= 2
485-- length longRevArgs >= 2
486-- length shortRevArgs < length longRevArgs
487--
488diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc
489diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
490 let
491 (a:b:cs, x:y:zs) =
492 case toGreedyMatch localizer shortRevArgs longRevArgs of
493 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
494 ( reverse (shortResult:shortRevArgDocs)
495 , reverse (longResult:longRevArgDocs)
496 )
498 Nothing ->
499 case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of
500 Just (GreedyMatch shortArgDocs longArgDocs) ->
501 ( shortArgDocs ++ [shortResult]
502 , longArgDocs ++ [longResult]
503 )
505 Nothing ->
506 let
507 toYellowDoc tipe =
508 D.dullyellow (toDoc localizer RT.Func tipe)
509 in
510 ( reverse (shortResult : map toYellowDoc shortRevArgs)
511 , reverse (longResult : map toYellowDoc longRevArgs )
512 )
513 in
514 different
515 (RT.lambda ctx a b cs)
516 (RT.lambda ctx x y zs)
517 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
521-- GREEDY ARG MATCHER
524data GreedyMatch =
525 GreedyMatch [D.Doc] [D.Doc]
528--
529-- INVARIANTS:
530-- length shorterArgs < length longerArgs
531--
532toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
533toGreedyMatch localizer shorterArgs longerArgs =
534 toGreedyMatchHelp localizer shorterArgs longerArgs (GreedyMatch [] [])
537toGreedyMatchHelp :: L.Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
538toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
539 let
540 toYellowDoc tipe =
541 D.dullyellow (toDoc localizer RT.Func tipe)
542 in
543 case (shorterArgs, longerArgs) of
544 (x:xs, y:ys) ->
545 case toDiff localizer RT.Func x y of
546 Diff a b Similar ->
547 toGreedyMatchHelp localizer xs ys $
548 GreedyMatch (a:shorterDocs) (b:longerDocs)
550 Diff _ _ (Different _) ->
551 toGreedyMatchHelp localizer shorterArgs ys $
552 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
554 ([], []) ->
555 Just match
557 ([], _:_) ->
558 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
560 (_:_, []) ->
561 Nothing
565-- RECORD DIFFS
568diffRecord :: L.Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff D.Doc
569diffRecord localizer fields1 ext1 fields2 ext2 =
570 let
571 toUnknownDocs field tipe =
572 ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )
574 toOverlapDocs field t1 t2 =
575 (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
577 left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
578 both = Map.intersectionWithKey toOverlapDocs fields1 fields2
579 right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)
581 fieldsDiff =
582 Map.elems <$>
583 if Map.null left && Map.null right then
584 sequenceA both
585 else
586 Map.union
587 <$> sequenceA both
588 <*> Diff left right (Different Bag.empty)
590 (Diff doc1 doc2 status) =
591 RT.record
592 <$> fieldsDiff
593 <*> extToDiff ext1 ext2
594 in
595 Diff doc1 doc2 $ merge status $
596 case (hasFixedFields ext1, hasFixedFields ext2) of
597 (True, True) ->
598 case Map.lookupMin left of
599 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
600 Nothing ->
601 if Map.null right
602 then Similar
603 else Different $ Bag.one $ FieldsMissing (Map.keys right)
605 (False, True) ->
606 case Map.lookupMin left of
607 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
608 Nothing -> Similar
610 (True, False) ->
611 case Map.lookupMin right of
612 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
613 Nothing -> Similar
615 (False, False) ->
616 Similar
619hasFixedFields :: Extension -> Bool
620hasFixedFields ext =
621 case ext of
622 Closed -> True
623 FlexOpen _ -> False
624 RigidOpen _ -> True
628-- DIFF RECORD EXTENSION
631extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
632extToDiff ext1 ext2 =
633 let
634 status = extToStatus ext1 ext2
635 extDoc1 = extToDoc ext1
636 extDoc2 = extToDoc ext2
637 in
638 case status of
639 Similar ->
640 Diff extDoc1 extDoc2 status
642 Different _ ->
643 Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
646extToStatus :: Extension -> Extension -> Status
647extToStatus ext1 ext2 =
648 case ext1 of
649 Closed ->
650 case ext2 of
651 Closed -> Similar
652 FlexOpen _ -> Similar
653 RigidOpen _ -> Different Bag.empty
655 FlexOpen _ ->
656 Similar
658 RigidOpen x ->
659 case ext2 of
660 Closed -> Different Bag.empty
661 FlexOpen _ -> Similar
662 RigidOpen y ->
663 if x == y
664 then Similar
665 else Different $ Bag.one $ BadRigidVar x (RigidVar y)