git.iko.soy/elk
on f91c6d0 help sign in
elk/compiler/src/Type/Error.hs
776 lines 20 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Error
4 ( Type(..)
5 , Super(..)
6 , Extension(..)
7 , iteratedDealias
8 , getFields
9 , toDoc
10 , Comparison(..)
11 , Problem(..)
12 , toComparison
13 , isInt
14 , isFloat
15 , isString
16 , isChar
17 , isList
18 )
19 where
22import qualified Data.Map as Map
23import qualified Data.Maybe as Maybe
25import qualified AST.Module.Name as ModuleName
26import qualified Data.Bag as Bag
27import qualified Elm.Name as N
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 N.Name
42 | FlexSuper Super N.Name
43 | RigidVar N.Name
44 | RigidSuper Super N.Name
45 | Type ModuleName.Canonical N.Name [Type]
46 | Record (Map.Map N.Name Type) Extension
47 | Unit
48 | Tuple Type Type (Maybe Type)
49 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
52data Super
53 = Number
54 | Comparable
55 | Appendable
56 | CompAppend
57 deriving (Eq)
60data Extension
61 = Closed
62 | FlexOpen N.Name
63 | RigidOpen N.Name
66iteratedDealias :: Type -> Type
67iteratedDealias tipe =
68 case tipe of
69 Alias _ _ _ real ->
70 iteratedDealias real
72 _ ->
73 tipe
76getFields :: Type -> Maybe (Map.Map N.Name Type)
77getFields tipe =
78 case tipe of
79 Alias _ _ _ real ->
80 getFields real
82 Record fields _ ->
83 Just fields
85 _ ->
86 Nothing
90-- TO DOC
93nameToDoc :: L.Localizer -> ModuleName.Canonical -> N.Name -> D.Doc
94nameToDoc localizer (ModuleName.Canonical _ home) name =
95 L.toDoc localizer home name
98toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
99toDoc localizer ctx tipe =
100 case tipe of
101 Lambda a b cs ->
102 RT.lambda ctx
103 (toDoc localizer RT.Func a)
104 (toDoc localizer RT.Func b)
105 (map (toDoc localizer RT.Func) cs)
107 Infinite ->
108 "∞"
110 Error ->
111 "?"
113 FlexVar name ->
114 D.fromName name
116 FlexSuper _ name ->
117 D.fromName name
119 RigidVar name ->
120 D.fromName name
122 RigidSuper _ name ->
123 D.fromName name
125 Type home name args ->
126 RT.apply ctx
127 (nameToDoc localizer home name)
128 (map (toDoc localizer RT.App) args)
130 Record fields ext ->
131 let
132 entryToDocs (fieldName, fieldType) =
133 ( D.fromName fieldName, toDoc localizer RT.None fieldType )
135 fieldDocs =
136 map entryToDocs (Map.toList fields)
137 in
138 RT.record fieldDocs $
139 case ext of
140 Closed -> Nothing
141 FlexOpen x -> Just (D.fromName x)
142 RigidOpen x -> Just (D.fromName x)
144 Unit ->
145 "()"
147 Tuple a b maybeC ->
148 RT.tuple
149 (toDoc localizer RT.None a)
150 (toDoc localizer RT.None b)
151 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
153 Alias home name args _ ->
154 RT.apply ctx
155 (nameToDoc localizer home name)
156 (map (toDoc localizer RT.App . snd) args)
160-- DIFF
163data Diff
164 = Similar Type Type
165 | DiffLambda Aliases Diff Diff [Diff]
166 | DiffType Aliases ModuleName.Canonical N.Name [Diff]
167 | DiffRecord Aliases [N.Name] (Map.Map N.Name Diff) [N.Name] Extension Extension
168 | DiffTuple Aliases Diff Diff (Maybe Diff)
169 | Clash Type Type
172same :: Type -> Diff
173same tipe =
174 Similar tipe tipe
177data Aliases =
178 Aliases
179 { _left :: Maybe N.Name
180 , _right :: Maybe N.Name
181 }
184{-# NOINLINE noAliases #-}
185noAliases :: Aliases
186noAliases =
187 Aliases Nothing Nothing
190toDiff :: Type -> Type -> Diff
191toDiff t1 t2 =
192 case (t1, t2) of
193 (Unit , Unit ) -> same t1
194 (Error , Error ) -> same t1
195 (Infinite, Infinite) -> same t1
197 (FlexVar x, FlexVar y) | x == y -> same t1
198 (FlexSuper _ x, FlexSuper _ y) | x == y -> same t1
199 (RigidVar x, RigidVar y) | x == y -> same t1
200 (RigidSuper _ x, RigidSuper _ y) | x == y -> same t1
202 (FlexVar _ , _ ) -> Similar t1 t2
203 (_ , FlexVar _ ) -> Similar t1 t2
205 (Lambda a1 b1 cs1, Lambda a2 b2 cs2) | length cs1 == length cs2 ->
206 let
207 a = toDiff a1 a2
208 b = toDiff b1 b2
209 cs = zipWith toDiff cs1 cs2
210 in
211 if isSimilar a && isSimilar b && all isSimilar cs
212 then Similar t1 t2
213 else DiffLambda noAliases a b cs
215 (Tuple a1 b1 Nothing, Tuple a2 b2 Nothing) ->
216 let
217 a = toDiff a1 a2
218 b = toDiff b1 b2
219 in
220 if isSimilar a && isSimilar b
221 then Similar t1 t2
222 else DiffTuple noAliases a b Nothing
224 (Tuple a1 b1 (Just c1), Tuple a2 b2 (Just c2)) ->
225 let
226 a = toDiff a1 a2
227 b = toDiff b1 b2
228 c = toDiff c1 c2
229 in
230 if isSimilar a && isSimilar b && isSimilar c
231 then Similar t1 t2
232 else DiffTuple noAliases a b (Just c)
234 (Record fields1 ext1, Record fields2 ext2) ->
235 let
236 left = Map.keys (Map.difference fields1 fields2)
237 both = Map.intersectionWith toDiff fields1 fields2
238 right = Map.keys (Map.difference fields2 fields1)
239 in
240 if null left && null right && all isSimilar both && isExtSimilar ext1 ext2
241 then Similar t1 t2
242 else DiffRecord noAliases left both right ext1 ext2
244 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
245 let
246 args = zipWith toDiff args1 args2
247 in
248 if all isSimilar args
249 then Similar t1 t2
250 else DiffType noAliases home1 name1 args
252 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
253 let
254 args = zipWith toDiff (map snd args1) (map snd args2)
255 in
256 if all isSimilar args
257 then Similar t1 t2
258 else DiffType noAliases home1 name1 args
260 (alias@(Alias _ name _ tipe1), tipe2) ->
261 addAlias (const alias) id (\(Aliases _ t) -> Aliases (Just name) t) (toDiff tipe1 tipe2)
263 (tipe1, alias@(Alias _ name _ tipe2)) ->
264 addAlias id (const alias) (\(Aliases t _) -> Aliases t (Just name)) (toDiff tipe1 tipe2)
266 _ ->
267 Clash t1 t2
270isSimilar :: Diff -> Bool
271isSimilar diff =
272 case diff of
273 Similar _ _ -> True
274 DiffLambda _ _ _ _ -> False
275 DiffType _ _ _ _ -> False
276 DiffRecord _ _ _ _ _ _ -> False
277 DiffTuple _ _ _ _ -> False
278 Clash _ _ -> False
281addAlias :: (Type -> Type) -> (Type -> Type) -> (Aliases -> Aliases) -> Diff -> Diff
282addAlias updateLeft updateRight updateAliases diff =
283 case diff of
284 Similar t1 t2 ->
285 Similar (updateLeft t1) (updateRight t2)
287 DiffLambda aliases a b cs ->
288 DiffLambda (updateAliases aliases) a b cs
290 DiffType aliases home name args ->
291 DiffType (updateAliases aliases) home name args
293 DiffRecord aliases lefts boths rights ext1 ext2 ->
294 DiffRecord (updateAliases aliases) lefts boths rights ext1 ext2
296 DiffTuple aliases a b maybeC ->
297 DiffTuple (updateAliases aliases) a b maybeC
299 Clash t1 t2 ->
300 Clash (updateLeft t1) (updateRight t2)
304-- COMPARISON
307data Comparison =
308 Comparison
309 { _alias1 :: Maybe N.Name
310 , _type1 :: D.Doc
311 , _alias2 :: Maybe N.Name
312 , _type2 :: D.Doc
313 , _problems :: [Problem]
314 }
317data Problem
318 = FieldMismatch [N.Name] [N.Name]
319 | IntFloat
320 | StringFromInt
321 | StringFromFloat
322 | StringToInt
323 | StringToFloat
324 | AnythingToBool
325 | AnythingFromMaybe
326 | AnythingToList
327 | MissingArgs Int
328 | ReturnMismatch
329 | BadFlexSuper Super N.Name Type
330 | BadRigidVar N.Name Type
331 | BadRigidSuper Super N.Name Type
334toComparison :: L.Localizer -> Type -> Type -> Comparison
335toComparison localizer a b =
336 let
337 diff = toDiff a b
338 (Aliases aAlias bAlias) = getAliases diff
339 (Pair aDoc bDoc problems) = diffToPair localizer RT.None diff
340 in
341 Comparison aAlias aDoc bAlias bDoc (Bag.toList problems)
344getAliases :: Diff -> Aliases
345getAliases diff =
346 case diff of
347 Similar _ _ -> noAliases
348 DiffLambda aliases _ _ _ -> aliases
349 DiffType aliases _ _ _ -> aliases
350 DiffRecord aliases _ _ _ _ _ -> aliases
351 DiffTuple aliases _ _ _ -> aliases
352 Clash _ _ -> noAliases
356-- DIFF TO DOCS
359data Pair a =
360 Pair a a (Bag.Bag Problem)
363instance Functor Pair where
364 fmap func (Pair a b ps) =
365 Pair (func a) (func b) ps
368instance Applicative Pair where
369 pure a =
370 Pair a a Bag.empty
372 (<*>) (Pair aFunc bFunc ps1) (Pair aArg bArg ps2) =
373 Pair (aFunc aArg) (bFunc bArg) (Bag.append ps1 ps2)
376diffToPair :: L.Localizer -> RT.Context -> Diff -> Pair D.Doc
377diffToPair localizer ctx diff =
378 case diff of
379 Similar tipe1 tipe2 ->
380 Pair (toDoc localizer ctx tipe1) (toDoc localizer ctx tipe2) Bag.empty
382 DiffLambda _ a b cs ->
383 RT.lambda ctx
384 <$> diffToPair localizer RT.Func a
385 <*> diffToPair localizer RT.Func b
386 <*> traverse (diffToPair localizer RT.Func) cs
388 DiffType _ home name args ->
389 RT.apply ctx (nameToDoc localizer home name)
390 <$> traverse (diffToPair localizer RT.App) args
392 DiffRecord _ left both right ext1 ext2 ->
393 diffRecord localizer left both right ext1 ext2
395 DiffTuple _ a b maybeC ->
396 RT.tuple
397 <$> diffToPair localizer RT.None a
398 <*> diffToPair localizer RT.None b
399 <*> traverse (diffToPair localizer RT.None) (Maybe.maybeToList maybeC)
401 Clash tipe1 tipe2 ->
402 case (tipe1, tipe2) of
403 (Lambda a b cs, Lambda x y zs) ->
404 diffLambda localizer ctx (a:b:cs) (x:y:zs)
406 (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff t1 t2) ->
407 Pair (yellowApply localizer ctx home name t1) (toDoc localizer ctx t2) (Bag.one AnythingFromMaybe)
409 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff t1 t2) ->
410 Pair (toDoc localizer ctx t1) (yellowApply localizer ctx home name t2) (Bag.one AnythingToList)
412 pair ->
413 let
414 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
415 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
416 in
417 Pair doc1 doc2 $
418 case pair of
419 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
420 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
421 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
422 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
423 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper s x other
424 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
426 (Type home1 name1 [], Type home2 name2 [])
427 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
428 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
429 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
430 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
431 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
432 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
433 | isBool home2 name2 -> Bag.one AnythingToBool
435 (_, _) -> Bag.empty
438isBool :: ModuleName.Canonical -> N.Name -> Bool
439isBool home name =
440 home == ModuleName.basics && name == N.bool
443isInt :: ModuleName.Canonical -> N.Name -> Bool
444isInt home name =
445 home == ModuleName.basics && name == N.int
448isFloat :: ModuleName.Canonical -> N.Name -> Bool
449isFloat home name =
450 home == ModuleName.basics && name == N.float
453isString :: ModuleName.Canonical -> N.Name -> Bool
454isString home name =
455 home == ModuleName.string && name == N.string
458isChar :: ModuleName.Canonical -> N.Name -> Bool
459isChar home name =
460 home == ModuleName.char && name == N.char
463isMaybe :: ModuleName.Canonical -> N.Name -> Bool
464isMaybe home name =
465 home == ModuleName.maybe && name == N.maybe
468isList :: ModuleName.Canonical -> N.Name -> Bool
469isList home name =
470 home == ModuleName.list && name == N.list
473yellowApply :: L.Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> D.Doc
474yellowApply localizer ctx home name tipe =
475 RT.apply ctx
476 (D.dullyellow (nameToDoc localizer home name))
477 [toDoc localizer RT.App tipe]
481-- DIFF LAMBDAS
484--
485-- INVARIANTS:
486-- length types1 >= 2
487-- length types2 >= 2
488-- length types1 /= length types2
489--
490diffLambda :: L.Localizer -> RT.Context -> [Type] -> [Type] -> Pair D.Doc
491diffLambda localizer ctx types1 types2 =
492 let
493 (result1:revArgs1) = reverse types1
494 (result2:revArgs2) = reverse types2
496 numArgs1 = length revArgs1
497 numArgs2 = length revArgs2
499 diff = toDiff result1 result2
501 (Pair r1 r2 _) = diffToPair localizer RT.Func diff
502 in
503 if isSimilar diff then
505 if numArgs1 < numArgs2 then
506 diffArgMismatch localizer ctx revArgs1 r1 revArgs2 r2
507 else
508 diffArgMismatch localizer ctx revArgs2 r2 revArgs1 r1
510 else
511 let
512 (a1:b1:cs1) = reverse (r1 : map (toDoc localizer RT.Func) revArgs1)
513 (a2:b2:cs2) = reverse (r2 : map (toDoc localizer RT.Func) revArgs2)
514 in
515 Pair
516 (D.dullyellow (RT.lambda ctx a1 b1 cs1))
517 (D.dullyellow (RT.lambda ctx a2 b2 cs2))
518 (Bag.one ReturnMismatch)
521--
522-- INVARIANTS:
523-- length shortRevArgs >= 2
524-- length longRevArgs >= 2
525--
526diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Pair D.Doc
527diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
528 case toGreedyMatch localizer shortRevArgs longRevArgs of
529 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
530 let
531 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
532 (x:y:zs) = reverse (longResult:longRevArgDocs)
533 in
534 Pair
535 (RT.lambda ctx a b cs)
536 (RT.lambda ctx x y zs)
537 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
539 Nothing ->
540 case toGreedyMatch localizer (reverse shortRevArgs) (reverse longRevArgs) of
541 Just (GreedyMatch shortArgDocs longArgDocs) ->
542 let
543 (a:b:cs) = shortArgDocs ++ [shortResult]
544 (x:y:zs) = longArgDocs ++ [longResult]
545 in
546 Pair
547 (RT.lambda ctx a b cs)
548 (RT.lambda ctx x y zs)
549 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
551 Nothing ->
552 let
553 toYellowDoc tipe =
554 D.dullyellow (toDoc localizer RT.Func tipe)
556 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
557 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
558 in
559 Pair
560 (RT.lambda ctx a b cs)
561 (RT.lambda ctx x y zs)
562 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
566-- GREEDY ARG MATCHER
569data GreedyMatch =
570 GreedyMatch [D.Doc] [D.Doc]
573--
574-- INVARIANTS:
575-- length shorterArgs < length longerArgs
576--
577toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
578toGreedyMatch localizer shorterArgs longerArgs =
579 toGreedyMatchHelp localizer shorterArgs longerArgs (GreedyMatch [] [])
582toGreedyMatchHelp :: L.Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
583toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
584 let
585 toYellowDoc tipe =
586 D.dullyellow (toDoc localizer RT.Func tipe)
587 in
588 case (shorterArgs, longerArgs) of
589 (x:xs, y:ys) ->
590 case toDiff x y of
591 Similar a b ->
592 toGreedyMatchHelp localizer xs ys $
593 GreedyMatch
594 (toDoc localizer RT.Func a : shorterDocs)
595 (toDoc localizer RT.Func b : longerDocs)
597 _ ->
598 toGreedyMatchHelp localizer shorterArgs ys $
599 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
601 ([], []) ->
602 Just match
604 ([], _:_) ->
605 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
607 (_:_, []) ->
608 Nothing
612-- RECORD DIFFS
615diffRecord
616 :: L.Localizer
617 -> [N.Name]
618 -> Map.Map N.Name Diff
619 -> [N.Name]
620 -> Extension
621 -> Extension
622 -> Pair D.Doc
623diffRecord localizer only1 both only2 ext1 ext2 =
624 if null only1 && null only2 then
625 case findBadOverlaps localizer both of
626 [] ->
627 case diffExt ext1 ext2 of
628 ExtSimilar ->
629 Pair
630 (toBoringRecord (Map.size both) ext1)
631 (toBoringRecord (Map.size both) ext2)
632 Bag.empty
634 ExtDifferent maybeExt1 maybeExt2 problems ->
635 Pair
636 (RT.record [] (fmap (D.dullyellow . D.fromName) maybeExt1))
637 (RT.record [] (fmap (D.dullyellow . D.fromName) maybeExt2))
638 problems
640 overlaps@(bad:bads) ->
641 if length overlaps < Map.size both then
642 Pair
643 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
644 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
645 (foldr Bag.append Bag.empty (map _problemBag overlaps))
646 else
647 Pair
648 (toOverlapRecord _doc1 bad bads ext1)
649 (toOverlapRecord _doc2 bad bads ext2)
650 (foldr Bag.append Bag.empty (map _problemBag overlaps))
652 else
653 Pair
654 (toMissingDoc (Map.size both) only1 ext1)
655 (toMissingDoc (Map.size both) only2 ext2)
656 (Bag.one (FieldMismatch only1 only2))
659toOverlapDoc :: (BadOverlap -> D.Doc) -> BadOverlap -> (D.Doc, D.Doc)
660toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
661 (D.fromName field, getDoc overlap)
664toOverlapRecord :: (BadOverlap -> D.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> D.Doc
665toOverlapRecord getDoc bad bads ext =
666 let go = toOverlapDoc getDoc in
667 case ext of
668 Closed -> RT.record (map go (bad:bads)) Nothing
669 FlexOpen _ -> RT.recordSnippet (go bad) (map go bads)
670 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
673toMissingDoc :: Int -> [N.Name] -> Extension -> D.Doc
674toMissingDoc numSharedFields uniqueFields ext =
675 case map emphasizeFieldName uniqueFields of
676 [] ->
677 toBoringRecord numSharedFields ext
679 doc:docs ->
680 if length uniqueFields < numSharedFields then
681 RT.recordSnippet doc docs
682 else
683 case ext of
684 Closed -> RT.record (doc:docs) Nothing
685 FlexOpen _ -> RT.recordSnippet doc docs
686 RigidOpen _ -> RT.recordSnippet doc docs
689emphasizeFieldName :: N.Name -> (D.Doc, D.Doc)
690emphasizeFieldName field =
691 ( D.dullyellow (D.fromName field), "..." )
694toBoringRecord :: Int -> Extension -> D.Doc
695toBoringRecord numFields ext =
696 case ext of
697 Closed -> if numFields == 0 then "{}" else "{ ... }"
698 FlexOpen _ -> "{ ... }"
699 RigidOpen _ -> "{ ... }"
703-- DIFF RECORD EXTENSION
706isExtSimilar :: Extension -> Extension -> Bool
707isExtSimilar ext1 ext2 =
708 case diffExt ext1 ext2 of
709 ExtSimilar ->
710 True
712 ExtDifferent _ _ _ ->
713 False
716data ExtDiff
717 = ExtSimilar
718 | ExtDifferent (Maybe N.Name) (Maybe N.Name) (Bag.Bag Problem)
721diffExt :: Extension -> Extension -> ExtDiff
722diffExt ext1 ext2 =
723 let
724 different x y = ExtDifferent x y Bag.empty
725 in
726 case ext1 of
727 Closed ->
728 case ext2 of
729 Closed -> ExtSimilar
730 FlexOpen y -> different Nothing (Just y)
731 RigidOpen y -> different Nothing (Just y)
733 FlexOpen x ->
734 case ext2 of
735 Closed -> different (Just x) Nothing
736 FlexOpen _ -> ExtSimilar
737 RigidOpen _ -> ExtSimilar
739 RigidOpen x ->
740 case ext2 of
741 Closed -> different (Just x) Nothing
742 FlexOpen _ -> ExtSimilar
743 RigidOpen y ->
744 if x == y then
745 ExtSimilar
746 else
747 ExtDifferent (Just x) (Just y) (Bag.one (BadRigidVar x (RigidVar y)))
751-- BAD OVERLAP
754data BadOverlap =
755 BadOverlap
756 { _field :: N.Name
757 , _doc1 :: D.Doc
758 , _doc2 :: D.Doc
759 , _problemBag :: Bag.Bag Problem
760 }
763findBadOverlaps :: L.Localizer -> Map.Map N.Name Diff -> [BadOverlap]
764findBadOverlaps localizer overlaps =
765 Map.foldrWithKey (addBadOverlap localizer) [] overlaps
768addBadOverlap :: L.Localizer -> N.Name -> Diff -> [BadOverlap] -> [BadOverlap]
769addBadOverlap localizer field diff badOverlaps =
770 if isSimilar diff then
771 badOverlaps
772 else
773 let
774 (Pair aDoc bDoc problems) = diffToPair localizer RT.None diff
775 in
776 BadOverlap field aDoc bDoc problems : badOverlaps