git.iko.soy/elk
on d924db7 help sign in
elk/src/Type/Error.hs
554 lines 15 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Error
4 ( Type(..)
5 , Extension(..)
6 , iteratedDealias
7 , Localizer
8 , toDoc
9 , toDiffDocs
10 , Problem(..)
11 )
12 where
15import qualified Data.Map as Map
16import qualified Data.Maybe as Maybe
17import Data.Monoid ((<>))
19import qualified AST.Module.Name as ModuleName
20import qualified Data.Bag as Bag
21import qualified Elm.Name as N
22import qualified Reporting.Helpers as H
23import qualified Reporting.Render.Type as RT
27-- ERROR TYPES
30data Type
31 = Lambda Type Type [Type]
32 | Infinite
33 | Error
34 | FlexVar N.Name
35 | FlexSuper N.Name
36 | RigidVar N.Name
37 | RigidSuper N.Name
38 | Type ModuleName.Canonical N.Name [Type]
39 | Record (Map.Map N.Name Type) Extension
40 | Unit
41 | Tuple Type Type (Maybe Type)
42 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
45data Extension
46 = Closed
47 | FlexOpen N.Name
48 | RigidOpen N.Name
51iteratedDealias :: Type -> Type
52iteratedDealias tipe =
53 case tipe of
54 Alias _ _ _ realType ->
55 iteratedDealias realType
57 _ ->
58 tipe
62-- TO DOC
65type Localizer = Map.Map (ModuleName.Canonical, N.Name) String
68nameToDoc :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
69nameToDoc dict home@(ModuleName.Canonical _ moduleName) name =
70 case Map.lookup (home, name) dict of
71 Nothing ->
72 H.nameToDoc moduleName <> "." <> H.nameToDoc name
74 Just string ->
75 H.text string
78toDoc :: Localizer -> RT.Context -> Type -> H.Doc
79toDoc dict ctx tipe =
80 case tipe of
81 Lambda a b cs ->
82 RT.lambda ctx
83 (toDoc dict RT.Func a)
84 (toDoc dict RT.Func b)
85 (map (toDoc dict RT.Func) cs)
87 Infinite ->
88 "∞"
90 Error ->
91 "?"
93 FlexVar name ->
94 H.nameToDoc name
96 FlexSuper name ->
97 H.nameToDoc name
99 RigidVar name ->
100 H.nameToDoc name
102 RigidSuper name ->
103 H.nameToDoc name
105 Type home name args ->
106 RT.apply ctx
107 (nameToDoc dict home name)
108 (map (toDoc dict RT.App) args)
110 Record fields ext ->
111 let
112 entryToDocs (fieldName, fieldType) =
113 ( H.nameToDoc fieldName, toDoc dict RT.None fieldType )
115 fieldDocs =
116 map entryToDocs (Map.toList fields)
117 in
118 RT.record fieldDocs $
119 case ext of
120 Closed -> Nothing
121 FlexOpen x -> Just (H.nameToDoc x)
122 RigidOpen x -> Just (H.nameToDoc x)
125 Unit ->
126 "()"
128 Tuple a b maybeC ->
129 RT.tuple
130 (toDoc dict RT.None a)
131 (toDoc dict RT.None b)
132 (map (toDoc dict RT.None) (Maybe.maybeToList maybeC))
134 Alias home name args _ ->
135 RT.apply ctx
136 (nameToDoc dict home name)
137 (map (toDoc dict RT.App . snd) args)
141-- DIFF
144toDiffDocs :: Localizer -> Type -> Type -> (H.Doc, H.Doc, [Problem])
145toDiffDocs dict a b =
146 case diff dict RT.None a b of
147 Similar aDoc bDoc ->
148 (aDoc, bDoc, [])
150 Different aDoc bDoc problems ->
151 (aDoc, bDoc, Bag.toList problems)
154data Diff a
155 = Similar a a
156 | Different a a (Bag.Bag Problem)
159instance Functor Diff where
160 fmap func d =
161 case d of
162 Similar a b -> Similar (func a) (func b)
163 Different a b ps -> Different (func a) (func b) ps
166instance Applicative Diff where
167 pure a =
168 Similar a a
170 (<*>) dFunc dArg =
171 case dFunc of
172 Similar aFunc bFunc ->
173 case dArg of
174 Similar a b -> Similar (aFunc a) (bFunc b)
175 Different a b ps -> Different (aFunc a) (bFunc b) ps
177 Different aFunc bFunc ps ->
178 case dArg of
179 Similar a b -> Different (aFunc a) (bFunc b) ps
180 Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
184-- PROBLEMS
187data Problem
188 = FieldMismatch [N.Name] [N.Name]
189 | IntFloat
190 | MissingArgs Int
191 | ReturnMismatch
192 | TupleMismatch
193 | BadFlexSuper N.Name Type
194 | BadRigidVar N.Name Type
195 | BadRigidSuper N.Name Type
199-- COMPUTE DIFF
202diff :: Localizer -> RT.Context -> Type -> Type -> Diff H.Doc
203diff dict ctx tipe1 tipe2 =
204 case (tipe1, tipe2) of
205 (FlexVar x, FlexVar y) | x == y -> pure (H.nameToDoc x)
206 (FlexSuper x, FlexSuper y) | x == y -> pure (H.nameToDoc x)
207 (RigidVar x, RigidVar y) | x == y -> pure (H.nameToDoc x)
208 (RigidSuper x, RigidSuper y) | x == y -> pure (H.nameToDoc x)
210 (Infinite, Infinite) -> pure "∞"
211 (Error, Error) -> pure "?"
212 (Unit, Unit) -> pure "()"
214 (Tuple a b maybeC, Tuple x y maybeZ) ->
215 RT.tuple
216 <$> diff dict RT.None a x
217 <*> diff dict RT.None b y
218 <*>
219 case (maybeC, maybeZ) of
220 (Nothing, Nothing) -> pure []
221 (Just c , Nothing) -> Different [H.dullyellow (toDoc dict RT.None c)] [] (Bag.one TupleMismatch)
222 (Nothing, Just z ) -> Different [] [H.dullyellow (toDoc dict RT.None z)] (Bag.one TupleMismatch)
223 (Just c , Just z ) -> (:[]) <$> diff dict RT.None c z
225 (Record fields1 ext1, Record fields2 ext2) -> diffRecord dict fields1 ext1 fields2 ext2
227 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
228 RT.apply ctx (nameToDoc dict home1 name1) <$>
229 sequenceA (zipWith (diff dict RT.App) args1 args2)
231 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
232 RT.apply ctx (nameToDoc dict home1 name1) <$>
233 sequenceA (zipWith (diff dict RT.App) (map snd args1) (map snd args2))
235 (Alias _ _ _ alias1, other) -> diff dict ctx alias1 other
236 (other, Alias _ _ _ alias2) -> diff dict ctx other alias2
238 (Lambda a b cs, Lambda x y zs) -> diffLambda dict ctx (a:b:cs) (x:y:zs)
239 (Lambda a b cs, result ) -> diffLambda dict ctx (a:b:cs) [result]
240 (result , Lambda x y zs) -> diffLambda dict ctx [result] (x:y:zs)
242 (FlexVar x, other) -> Similar (H.nameToDoc x) (toDoc dict ctx other)
243 (other, FlexVar x) -> Similar (toDoc dict ctx other) (H.nameToDoc x)
245 pair ->
246 let
247 doc1 = H.dullyellow (toDoc dict ctx tipe1)
248 doc2 = H.dullyellow (toDoc dict ctx tipe2)
249 in
250 Different doc1 doc2 $
251 case pair of
252 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
253 (FlexSuper x, other) -> Bag.one $ BadFlexSuper x other
254 (RigidSuper x, other) -> Bag.one $ BadRigidSuper x other
255 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
256 (other, FlexSuper x) -> Bag.one $ BadFlexSuper x other
257 (other, RigidSuper x) -> Bag.one $ BadRigidSuper x other
259 (Type home1 name1 [], Type home2 name2 []) | isIntFloat home1 name1 home2 name2 -> Bag.one IntFloat
261 (_, _) -> Bag.empty
264isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool
265isIntFloat home1 name1 home2 name2 =
266 home1 == ModuleName.basics
267 &&
268 home2 == ModuleName.basics
269 &&
270 (
271 (name1 == N.int && name2 == N.float)
272 ||
273 (name1 == N.float && name2 == N.int)
274 )
278-- DIFF LAMBDAS
281--
282-- INVARIANT: notNull types1 && notNull types2
283--
284diffLambda :: Localizer -> RT.Context -> [Type] -> [Type] -> Diff H.Doc
285diffLambda dict ctx types1 types2 =
286 let
287 (result1:revArgs1) = reverse types1
288 (result2:revArgs2) = reverse types2
290 numArgs1 = length revArgs1
291 numArgs2 = length revArgs2
293 resultDiff = diff dict RT.Func result1 result2
294 in
295 case resultDiff of
296 Similar resultDoc1 resultDoc2 ->
297 if numArgs1 == numArgs2 then
298 (\resultDoc revArgsDoc ->
299 let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
300 RT.lambda ctx x y zs
301 )
302 <$> resultDiff
303 <*> sequenceA (zipWith (diff dict RT.Func) revArgs1 revArgs2)
305 else if numArgs1 < numArgs2 then
306 diffArgMismatch dict ctx revArgs1 resultDoc1 revArgs2 resultDoc2
308 else
309 diffArgMismatch dict ctx revArgs2 resultDoc2 revArgs1 resultDoc1
311 Different resultDoc1 resultDoc2 problems ->
312 let
313 (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc dict RT.Func) revArgs1)
314 (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc dict RT.Func) revArgs2)
315 in
316 Different
317 (RT.lambda ctx x1 y1 zs1)
318 (RT.lambda ctx x2 y2 zs2)
319 (Bag.append (Bag.one ReturnMismatch) problems)
322--
323-- INVARIANT: notNull shortRevArgs && notNull longRevArgs
324--
325diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
326diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
327 case toGreedyMatch dict shortRevArgs longRevArgs of
328 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
329 let
330 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
331 (x:y:zs) = reverse (longResult:longRevArgDocs)
332 in
333 Different
334 (RT.lambda ctx a b cs)
335 (RT.lambda ctx x y zs)
336 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
338 Nothing ->
339 case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) of
340 Just (GreedyMatch shortArgDocs longArgDocs) ->
341 let
342 (a:b:cs) = shortArgDocs ++ [shortResult]
343 (x:y:zs) = longArgDocs ++ [longResult ]
344 in
345 Different
346 (RT.lambda ctx a b cs)
347 (RT.lambda ctx x y zs)
348 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
350 Nothing ->
351 let
352 toYellowDoc tipe =
353 H.dullyellow (toDoc dict RT.Func tipe)
355 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
356 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
357 in
358 Different
359 (RT.lambda ctx a b cs)
360 (RT.lambda ctx x y zs)
361 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
365-- GREEDY ARG MATCHER
368data GreedyMatch =
369 GreedyMatch [H.Doc] [H.Doc]
372--
373-- INVARIANT: length shorterArgs < length longerArgs
374--
375toGreedyMatch :: Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
376toGreedyMatch dict shorterArgs longerArgs =
377 toGreedyMatchHelp dict shorterArgs longerArgs (GreedyMatch [] [])
380toGreedyMatchHelp :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
381toGreedyMatchHelp dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
382 let
383 toYellowDoc tipe =
384 H.dullyellow (toDoc dict RT.Func tipe)
385 in
386 case (shorterArgs, longerArgs) of
387 (x:xs, y:ys) ->
388 case diff dict RT.Func x y of
389 Similar a b ->
390 toGreedyMatchHelp dict xs ys $
391 GreedyMatch (a:shorterDocs) (b:longerDocs)
393 Different _ _ _ ->
394 toGreedyMatchHelp dict shorterArgs ys $
395 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
397 ([], []) ->
398 Just match
400 ([], _:_) ->
401 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
403 (_:_, []) ->
404 Nothing
408-- RECORD DIFFS
411diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
412diffRecord dict fields1 ext1 fields2 ext2 =
413 let
414 only1 = Map.keys (Map.difference fields1 fields2)
415 only2 = Map.keys (Map.difference fields2 fields1)
416 in
417 if null only1 && null only2 then
418 case findBadOverlaps dict fields1 fields2 of
419 [] ->
420 case diffExt ext1 ext2 of
421 Similar _ _ ->
422 Similar (toBoringRecord fields1 ext1) (toBoringRecord fields2 ext2)
424 Different dExt1 dExt2 problems ->
425 Different (RT.record [] dExt1) (RT.record [] dExt2) problems
427 overlaps@(bad:bads) ->
428 if length overlaps < Map.size fields1 then
429 Different
430 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
431 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
432 (foldr Bag.append Bag.empty (map _problems overlaps))
433 else
434 Different
435 (toOverlapRecord _doc1 bad bads ext1)
436 (toOverlapRecord _doc2 bad bads ext2)
437 (foldr Bag.append Bag.empty (map _problems overlaps))
439 else
440 Different
441 (toMissingDoc fields1 only1 ext1)
442 (toMissingDoc fields2 only2 ext2)
443 (Bag.one (FieldMismatch only1 only2))
446toOverlapDoc :: (BadOverlap -> H.Doc) -> BadOverlap -> (H.Doc, H.Doc)
447toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
448 (H.nameToDoc field, getDoc overlap)
451toOverlapRecord :: (BadOverlap -> H.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> H.Doc
452toOverlapRecord getDoc bad bads ext =
453 let go = toOverlapDoc getDoc in
454 case ext of
455 Closed -> RT.record (map go (bad:bads)) Nothing
456 FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)
457 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
460toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> H.Doc
461toMissingDoc allFields uniqueFields ext =
462 case map emphasizeFieldName uniqueFields of
463 [] ->
464 toBoringRecord allFields ext
466 doc:docs ->
467 if length uniqueFields < Map.size allFields then
468 RT.recordSnippet doc docs
469 else
470 case ext of
471 Closed -> RT.record (doc:docs) Nothing
472 FlexOpen _ -> RT.recordSnippet doc docs
473 RigidOpen _ -> RT.recordSnippet doc docs
476emphasizeFieldName :: N.Name -> (H.Doc, H.Doc)
477emphasizeFieldName field =
478 ( H.dullyellow (H.nameToDoc field), "..." )
481toBoringRecord :: Map.Map N.Name t -> Extension -> H.Doc
482toBoringRecord fields ext =
483 case ext of
484 Closed -> if Map.null fields then "{}" else "{ ... }"
485 FlexOpen _ -> "{ ... }"
486 RigidOpen _ -> "{ ... }"
490-- DIFF RECORD EXTENSION
493diffExt :: Extension -> Extension -> Diff (Maybe H.Doc)
494diffExt ext1 ext2 =
495 let
496 normal = Just . H.nameToDoc
497 yellow = Just . H.dullyellow . H.nameToDoc
499 different x y = Different x y Bag.empty
500 in
501 case ext1 of
502 Closed ->
503 case ext2 of
504 Closed -> Similar Nothing Nothing
505 FlexOpen y -> different Nothing (yellow y)
506 RigidOpen y -> different Nothing (yellow y)
508 FlexOpen x ->
509 case ext2 of
510 Closed -> different (yellow x) Nothing
511 FlexOpen y -> Similar (normal x) (normal y)
512 RigidOpen y -> Similar (normal x) (normal y)
514 RigidOpen x ->
515 case ext2 of
516 Closed -> different (yellow x) Nothing
517 FlexOpen y -> Similar (normal x) (normal y)
518 RigidOpen y ->
519 if x == y then
520 Similar (normal x) (normal y)
521 else
522 Different (yellow x) (yellow y) (Bag.one (BadRigidVar x (RigidVar y)))
526-- BAD OVERLAP
529data BadOverlap =
530 BadOverlap
531 { _field :: N.Name
532 , _doc1 :: H.Doc
533 , _doc2 :: H.Doc
534 , _problems :: Bag.Bag Problem
535 }
538findBadOverlaps :: Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
539findBadOverlaps dict fields1 fields2 =
540 findBadOverlapsHelp [] $ Map.toList $
541 Map.intersectionWith (diff dict RT.None) fields1 fields2
544findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff H.Doc)] -> [BadOverlap]
545findBadOverlapsHelp badOverlaps fieldPairs =
546 case fieldPairs of
547 [] ->
548 badOverlaps
550 (_, Similar _ _) : otherFieldPairs ->
551 findBadOverlapsHelp badOverlaps otherFieldPairs
553 (field, Different aDoc bDoc problems) : otherFieldPairs ->
554 findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs