@@ -5,9 +5,11 @@ module Type.Error
55 , Super(..)
66 , Extension(..)
77 , iteratedDealias
8+ , getFields
89 , toDoc
9− , toDiffDocs
10+ , Comparison(..)
1011 , Problem(..)
12+ , toComparison
1113 , isInt
1214 , isFloat
1315 , isString
@@ -52,6 +54,7 @@ data Super
5254 | Comparable
5355 | Appendable
5456 | CompAppend
57+ deriving (Eq)
5558
5659
5760data Extension
@@ -63,13 +66,26 @@ data Extension
6366iteratedDealias :: Type -> Type
6467iteratedDealias tipe =
6568 case tipe of
66− Alias _ _ _ realType ->
67− iteratedDealias realType
69+ Alias _ _ _ real ->
70+ iteratedDealias real
6871
6972 _ ->
7073 tipe
7174
7275
76+getFields :: Type -> Maybe [N.Name]
77+getFields tipe =
78+ case tipe of
79+ Alias _ _ _ real ->
80+ getFields real
81+
82+ Record fields _ ->
83+ Just (Map.keys fields)
84+
85+ _ ->
86+ Nothing
87+
88+
7389
7490-- TO DOC
7591
@@ -144,47 +160,158 @@ toDoc localizer ctx tipe =
144160-- DIFF
145161
146162
147−toDiffDocs :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
148−toDiffDocs localizer a b =
149− case diff localizer RT.None a b of
150− Similar aDoc bDoc ->
151− (aDoc, bDoc, [])
163+data 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
152170
153− Different aDoc bDoc problems ->
154− (aDoc, bDoc, Bag.toList problems)
155171
172+same :: Type -> Diff
173+same tipe =
174+ Similar tipe tipe
156175
157−data Diff a
158− = Similar a a
159− | Different a a (Bag.Bag Problem)
160176
177+data Aliases =
178+ Aliases
179+ { _left :: Maybe N.Name
180+ , _right :: Maybe N.Name
181+ }
161182
162−instance Functor Diff where
163− fmap func d =
164− case d of
165− Similar a b -> Similar (func a) (func b)
166− Different a b ps -> Different (func a) (func b) ps
167183
184+{-# NOINLINE noAliases #-}
185+noAliases :: Aliases
186+noAliases =
187+ Aliases Nothing Nothing
168188
169−instance Applicative Diff where
170− pure a =
171− Similar a a
172189
173− (<*>) dFunc dArg =
174− case dFunc of
175− Similar aFunc bFunc ->
176− case dArg of
177− Similar a b -> Similar (aFunc a) (bFunc b)
178− Different a b ps -> Different (aFunc a) (bFunc b) ps
190+toDiff :: Type -> Type -> Diff
191+toDiff t1 t2 =
192+ case (t1, t2) of
193+ (Unit , Unit ) -> same t1
194+ (Error , Error ) -> same t1
195+ (Infinite, Infinite) -> same t1
196+
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
201+
202+ (FlexVar _ , _ ) -> Similar t1 t2
203+ (_ , FlexVar _ ) -> Similar t1 t2
204+
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
214+
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
223+
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)
233+
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
243+
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
251+
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
259+
260+ (alias@(Alias _ name _ tipe1), tipe2) ->
261+ addAlias (const alias) id (\(Aliases _ t) -> Aliases (Just name) t) (toDiff tipe1 tipe2)
262+
263+ (tipe1, alias@(Alias _ name _ tipe2)) ->
264+ addAlias id (const alias) (\(Aliases t _) -> Aliases t (Just name)) (toDiff tipe1 tipe2)
265+
266+ _ ->
267+ Clash t1 t2
268+
269+
270+isSimilar :: Diff -> Bool
271+isSimilar diff =
272+ case diff of
273+ Similar _ _ -> True
274+ DiffLambda _ _ _ _ -> False
275+ DiffType _ _ _ _ -> False
276+ DiffRecord _ _ _ _ _ _ -> False
277+ DiffTuple _ _ _ _ -> False
278+ Clash _ _ -> False
279+
280+
281+addAlias :: (Type -> Type) -> (Type -> Type) -> (Aliases -> Aliases) -> Diff -> Diff
282+addAlias updateLeft updateRight updateAliases diff =
283+ case diff of
284+ Similar t1 t2 ->
285+ Similar (updateLeft t1) (updateRight t2)
286+
287+ DiffLambda aliases a b cs ->
288+ DiffLambda (updateAliases aliases) a b cs
289+
290+ DiffType aliases home name args ->
291+ DiffType (updateAliases aliases) home name args
292+
293+ DiffRecord aliases lefts boths rights ext1 ext2 ->
294+ DiffRecord (updateAliases aliases) lefts boths rights ext1 ext2
179295
180− Different aFunc bFunc ps ->
181− case dArg of
182− Similar a b -> Different (aFunc a) (bFunc b) ps
183− Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
296+ DiffTuple aliases a b maybeC ->
297+ DiffTuple (updateAliases aliases) a b maybeC
184298
299+ Clash t1 t2 ->
300+ Clash (updateLeft t1) (updateRight t2)
185301
186302
187−-- PROBLEMS
303+
304+-- COMPARISON
305+
306+
307+data 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+ }
188315
189316
190317data Problem
@@ -204,66 +331,90 @@ data Problem
204331 | BadRigidSuper Super N.Name Type
205332
206333
334+toComparison :: L.Localizer -> Type -> Type -> Comparison
335+toComparison 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)
207342
208−-- COMPUTE DIFF
209343
344+getAliases :: Diff -> Aliases
345+getAliases 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
210353
211−diff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
212−diff localizer ctx tipe1 tipe2 =
213− case (tipe1, tipe2) of
214− (FlexVar x, FlexVar y) | x == y -> pure (D.fromName x)
215− (FlexSuper _ x, FlexSuper _ y) | x == y -> pure (D.fromName x)
216− (RigidVar x, RigidVar y) | x == y -> pure (D.fromName x)
217− (RigidSuper _ x, RigidSuper _ y) | x == y -> pure (D.fromName x)
218354
219− (Infinite, Infinite) -> pure "∞"
220− (Error, Error) -> pure "?"
221− (Unit, Unit) -> pure "()"
222355
223− (Tuple a b maybeC, Tuple x y maybeZ) ->
224− RT.tuple
225− <$> diff localizer RT.None a x
226− <*> diff localizer RT.None b y
227− <*>
228− case (maybeC, maybeZ) of
229− (Nothing, Nothing) -> pure []
230− (Just c , Nothing) -> Different [D.dullyellow (toDoc localizer RT.None c)] [] Bag.empty
231− (Nothing, Just z ) -> Different [] [D.dullyellow (toDoc localizer RT.None z)] Bag.empty
232− (Just c , Just z ) -> (:[]) <$> diff localizer RT.None c z
356+-- DIFF TO DOCS
233357
234− (Record fields1 ext1, Record fields2 ext2) ->
235− diffRecord localizer fields1 ext1 fields2 ext2
236358
237− (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
238− RT.apply ctx (nameToDoc localizer home1 name1) <$>
239− sequenceA (zipWith (diff localizer RT.App) args1 args2)
359+data Pair a =
360+ Pair a a (Bag.Bag Problem)
240361
241− (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
242− RT.apply ctx (nameToDoc localizer home1 name1) <$>
243− sequenceA (zipWith (diff localizer RT.App) (map snd args1) (map snd args2))
244362
245− (Alias _ _ _ alias1, other) -> diff localizer ctx alias1 other
246− (other, Alias _ _ _ alias2) -> diff localizer ctx other alias2
363+instance Functor Pair where
364+ fmap func (Pair a b ps) =
365+ Pair (func a) (func b) ps
247366
248− (Lambda a b cs, Lambda x y zs) -> diffLambda localizer ctx (a:b:cs) (x:y:zs)
249367
250− (FlexVar x, other) -> Similar (D.fromName x) (toDoc localizer ctx other)
251− (other, FlexVar x) -> Similar (toDoc localizer ctx other) (D.fromName x)
368+instance Applicative Pair where
369+ pure a =
370+ Pair a a Bag.empty
252371
253− pair ->
254− case pair of
255− (Type home name [t1], t2) | isMaybe home name && isSimilar t1 t2 ->
256− Different (yellowApply localizer ctx home name t1) (toDoc localizer ctx t2) (Bag.one AnythingFromMaybe)
372+ (<*>) (Pair aFunc bFunc ps1) (Pair aArg bArg ps2) =
373+ Pair (aFunc aArg) (bFunc bArg) (Bag.append ps1 ps2)
257374
258− (t1, Type home name [t2]) | isList home name && isSimilar t1 t2 ->
259− Different (toDoc localizer ctx t1) (yellowApply localizer ctx home name t2) (Bag.one AnythingToList)
260375
261− _ ->
376+diffToPair :: L.Localizer -> RT.Context -> Diff -> Pair D.Doc
377+diffToPair localizer ctx diff =
378+ case diff of
379+ Similar tipe1 tipe2 ->
380+ Pair (toDoc localizer ctx tipe1) (toDoc localizer ctx tipe2) Bag.empty
381+
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
387+
388+ DiffType _ home name args ->
389+ RT.apply ctx (nameToDoc localizer home name)
390+ <$> traverse (diffToPair localizer RT.App) args
391+
392+ DiffRecord _ left both right ext1 ext2 ->
393+ diffRecord localizer left both right ext1 ext2
394+
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)
400+
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)
405+
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)
408+
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)
411+
412+ pair ->
262413 let
263414 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
264415 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
265416 in
266− Different doc1 doc2 $
417+ Pair doc1 doc2 $
267418 case pair of
268419 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
269420 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper s x other
@@ -319,13 +470,6 @@ isList home name =
319470 home == ModuleName.list && name == N.list
320471
321472
322−isSimilar :: Type -> Type -> Bool
323−isSimilar tipe1 tipe2 =
324− case diff L.empty RT.None tipe1 tipe2 of
325− Similar _ _ -> True
326− Different _ _ _ -> False
327−
328−
329473yellowApply :: L.Localizer -> RT.Context -> ModuleName.Canonical -> N.Name -> Type -> D.Doc
330474yellowApply localizer ctx home name tipe =
331475 RT.apply ctx
@@ -338,9 +482,12 @@ yellowApply localizer ctx home name tipe =
338482
339483
340484--
341−-- INVARIANT: length types1 >= 2 && length types2 >= 2
485+-- INVARIANTS:
486+-- length types1 >= 2
487+-- length types2 >= 2
488+-- length types1 /= length types2
342489--
343−diffLambda :: L.Localizer -> RT.Context -> [Type] -> [Type] -> Diff D.Doc
490+diffLambda :: L.Localizer -> RT.Context -> [Type] -> [Type] -> Pair D.Doc
344491diffLambda localizer ctx types1 types2 =
345492 let
346493 (result1:revArgs1) = reverse types1
@@ -349,39 +496,34 @@ diffLambda localizer ctx types1 types2 =
349496 numArgs1 = length revArgs1
350497 numArgs2 = length revArgs2
351498
352− resultDiff = diff localizer RT.Func result1 result2
499+ diff = toDiff result1 result2
500+
501+ (Pair r1 r2 _) = diffToPair localizer RT.Func diff
353502 in
354− case resultDiff of
355− Similar resultDoc1 resultDoc2 ->
356− if numArgs1 == numArgs2 then
357− (\resultDoc revArgsDoc ->
358− let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
359− RT.lambda ctx x y zs
360− )
361− <$> resultDiff
362− <*> sequenceA (zipWith (diff localizer RT.Func) revArgs1 revArgs2)
363−
364− else if numArgs1 < numArgs2 then
365− diffArgMismatch localizer ctx revArgs1 resultDoc1 revArgs2 resultDoc2
503+ if isSimilar diff then
366504
367− else
368− diffArgMismatch localizer ctx revArgs2 resultDoc2 revArgs1 resultDoc1
505+ if numArgs1 < numArgs2 then
506+ diffArgMismatch localizer ctx revArgs1 r1 revArgs2 r2
507+ else
508+ diffArgMismatch localizer ctx revArgs2 r2 revArgs1 r1
369509
370− Different resultDoc1 resultDoc2 problems ->
371− let
372− (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc localizer RT.Func) revArgs1)
373− (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc localizer RT.Func) revArgs2)
374− in
375− Different
376− (RT.lambda ctx x1 y1 zs1)
377− (RT.lambda ctx x2 y2 zs2)
378− (Bag.append (Bag.one ReturnMismatch) problems)
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)
379519
380520
381521--
382−-- INVARIANT: length shortRevArgs >= 2 && length longRevArgs >= 2
522+-- INVARIANTS:
523+-- length shortRevArgs >= 2
524+-- length longRevArgs >= 2
383525--
384−diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Diff D.Doc
526+diffArgMismatch :: L.Localizer -> RT.Context -> [Type] -> D.Doc -> [Type] -> D.Doc -> Pair D.Doc
385527diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
386528 case toGreedyMatch localizer shortRevArgs longRevArgs of
387529 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
@@ -389,7 +531,7 @@ diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
389531 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
390532 (x:y:zs) = reverse (longResult:longRevArgDocs)
391533 in
392− Different
534+ Pair
393535 (RT.lambda ctx a b cs)
394536 (RT.lambda ctx x y zs)
395537 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
@@ -399,9 +541,9 @@ diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
399541 Just (GreedyMatch shortArgDocs longArgDocs) ->
400542 let
401543 (a:b:cs) = shortArgDocs ++ [shortResult]
402− (x:y:zs) = longArgDocs ++ [longResult ]
544+ (x:y:zs) = longArgDocs ++ [longResult]
403545 in
404− Different
546+ Pair
405547 (RT.lambda ctx a b cs)
406548 (RT.lambda ctx x y zs)
407549 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
@@ -414,7 +556,7 @@ diffArgMismatch localizer ctx shortRevArgs shortResult longRevArgs longResult =
414556 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
415557 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
416558 in
417− Different
559+ Pair
418560 (RT.lambda ctx a b cs)
419561 (RT.lambda ctx x y zs)
420562 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
@@ -429,7 +571,8 @@ data GreedyMatch =
429571
430572
431573--
432−-- INVARIANT: length shorterArgs < length longerArgs
574+-- INVARIANTS:
575+-- length shorterArgs < length longerArgs
433576--
434577toGreedyMatch :: L.Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
435578toGreedyMatch localizer shorterArgs longerArgs =
@@ -444,12 +587,14 @@ toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDoc
444587 in
445588 case (shorterArgs, longerArgs) of
446589 (x:xs, y:ys) ->
447− case diff localizer RT.Func x y of
590+ case toDiff x y of
448591 Similar a b ->
449592 toGreedyMatchHelp localizer xs ys $
450− GreedyMatch (a:shorterDocs) (b:longerDocs)
593+ GreedyMatch
594+ (toDoc localizer RT.Func a : shorterDocs)
595+ (toDoc localizer RT.Func b : longerDocs)
451596
452− Different _ _ _ ->
597+ _ ->
453598 toGreedyMatchHelp localizer shorterArgs ys $
454599 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
455600
@@ -467,38 +612,47 @@ toGreedyMatchHelp localizer shorterArgs longerArgs match@(GreedyMatch shorterDoc
467612-- RECORD DIFFS
468613
469614
470−diffRecord :: L.Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff D.Doc
471−diffRecord localizer fields1 ext1 fields2 ext2 =
472− let
473− only1 = Map.keys (Map.difference fields1 fields2)
474− only2 = Map.keys (Map.difference fields2 fields1)
475− in
615+diffRecord
616+ :: L.Localizer
617+ -> [N.Name]
618+ -> Map.Map N.Name Diff
619+ -> [N.Name]
620+ -> Extension
621+ -> Extension
622+ -> Pair D.Doc
623+diffRecord localizer only1 both only2 ext1 ext2 =
476624 if null only1 && null only2 then
477− case findBadOverlaps localizer fields1 fields2 of
625+ case findBadOverlaps localizer both of
478626 [] ->
479627 case diffExt ext1 ext2 of
480− Similar _ _ ->
481− Similar (toBoringRecord fields1 ext1) (toBoringRecord fields2 ext2)
482−
483− Different dExt1 dExt2 problems ->
484− Different (RT.record [] dExt1) (RT.record [] dExt2) problems
628+ ExtSimilar ->
629+ Pair
630+ (toBoringRecord (Map.size both) ext1)
631+ (toBoringRecord (Map.size both) ext2)
632+ Bag.empty
633+
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
485639
486640 overlaps@(bad:bads) ->
487− if length overlaps < Map.size fields1 then
488− Different
641+ if length overlaps < Map.size both then
642+ Pair
489643 (RT.recordSnippet (toOverlapDoc _doc1 bad) (map (toOverlapDoc _doc1) bads))
490644 (RT.recordSnippet (toOverlapDoc _doc2 bad) (map (toOverlapDoc _doc2) bads))
491− (foldr Bag.append Bag.empty (map _problems overlaps))
645+ (foldr Bag.append Bag.empty (map _problemBag overlaps))
492646 else
493− Different
647+ Pair
494648 (toOverlapRecord _doc1 bad bads ext1)
495649 (toOverlapRecord _doc2 bad bads ext2)
496− (foldr Bag.append Bag.empty (map _problems overlaps))
650+ (foldr Bag.append Bag.empty (map _problemBag overlaps))
497651
498652 else
499− Different
500− (toMissingDoc fields1 only1 ext1)
501− (toMissingDoc fields2 only2 ext2)
653+ Pair
654+ (toMissingDoc (Map.size both) only1 ext1)
655+ (toMissingDoc (Map.size both) only2 ext2)
502656 (Bag.one (FieldMismatch only1 only2))
503657
504658
@@ -516,14 +670,14 @@ toOverlapRecord getDoc bad bads ext =
516670 RigidOpen _ -> RT.recordSnippet (go bad) (map go bads)
517671
518672
519−toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> D.Doc
520−toMissingDoc allFields uniqueFields ext =
673+toMissingDoc :: Int -> [N.Name] -> Extension -> D.Doc
674+toMissingDoc numSharedFields uniqueFields ext =
521675 case map emphasizeFieldName uniqueFields of
522676 [] ->
523− toBoringRecord allFields ext
677+ toBoringRecord numSharedFields ext
524678
525679 doc:docs ->
526− if length uniqueFields < Map.size allFields then
680+ if length uniqueFields < numSharedFields then
527681 RT.recordSnippet doc docs
528682 else
529683 case ext of
@@ -537,10 +691,10 @@ emphasizeFieldName field =
537691 ( D.dullyellow (D.fromName field), "..." )
538692
539693
540−toBoringRecord :: Map.Map N.Name t -> Extension -> D.Doc
541−toBoringRecord fields ext =
694+toBoringRecord :: Int -> Extension -> D.Doc
695+toBoringRecord numFields ext =
542696 case ext of
543− Closed -> if Map.null fields then "{}" else "{ ... }"
697+ Closed -> if numFields == 0 then "{}" else "{ ... }"
544698 FlexOpen _ -> "{ ... }"
545699 RigidOpen _ -> "{ ... }"
546700
@@ -549,36 +703,48 @@ toBoringRecord fields ext =
549703-- DIFF RECORD EXTENSION
550704
551705
552−diffExt :: Extension -> Extension -> Diff (Maybe D.Doc)
706+isExtSimilar :: Extension -> Extension -> Bool
707+isExtSimilar ext1 ext2 =
708+ case diffExt ext1 ext2 of
709+ ExtSimilar ->
710+ True
711+
712+ ExtDifferent _ _ _ ->
713+ False
714+
715+
716+data ExtDiff
717+ = ExtSimilar
718+ | ExtDifferent (Maybe N.Name) (Maybe N.Name) (Bag.Bag Problem)
719+
720+
721+diffExt :: Extension -> Extension -> ExtDiff
553722diffExt ext1 ext2 =
554723 let
555− normal = Just . D.fromName
556− yellow = Just . D.dullyellow . D.fromName
557−
558− different x y = Different x y Bag.empty
724+ different x y = ExtDifferent x y Bag.empty
559725 in
560726 case ext1 of
561727 Closed ->
562728 case ext2 of
563− Closed -> Similar Nothing Nothing
564− FlexOpen y -> different Nothing (yellow y)
565− RigidOpen y -> different Nothing (yellow y)
729+ Closed -> ExtSimilar
730+ FlexOpen y -> different Nothing (Just y)
731+ RigidOpen y -> different Nothing (Just y)
566732
567733 FlexOpen x ->
568734 case ext2 of
569− Closed -> different (yellow x) Nothing
570− FlexOpen y -> Similar (normal x) (normal y)
571− RigidOpen y -> Similar (normal x) (normal y)
735+ Closed -> different (Just x) Nothing
736+ FlexOpen _ -> ExtSimilar
737+ RigidOpen _ -> ExtSimilar
572738
573739 RigidOpen x ->
574740 case ext2 of
575− Closed -> different (yellow x) Nothing
576− FlexOpen y -> Similar (normal x) (normal y)
741+ Closed -> different (Just x) Nothing
742+ FlexOpen _ -> ExtSimilar
577743 RigidOpen y ->
578744 if x == y then
579− Similar (normal x) (normal y)
745+ ExtSimilar
580746 else
581− Different (yellow x) (yellow y) (Bag.one (BadRigidVar x (RigidVar y)))
747+ ExtDifferent (Just x) (Just y) (Bag.one (BadRigidVar x (RigidVar y)))
582748
583749
584750
@@ -590,24 +756,21 @@ data BadOverlap =
590756 { _field :: N.Name
591757 , _doc1 :: D.Doc
592758 , _doc2 :: D.Doc
593− , _problems :: Bag.Bag Problem
759+ , _problemBag :: Bag.Bag Problem
594760 }
595761
596762
597−findBadOverlaps :: L.Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
598−findBadOverlaps localizer fields1 fields2 =
599− findBadOverlapsHelp [] $ Map.toList $
600− Map.intersectionWith (diff localizer RT.None) fields1 fields2
601−
763+findBadOverlaps :: L.Localizer -> Map.Map N.Name Diff -> [BadOverlap]
764+findBadOverlaps localizer overlaps =
765+ Map.foldrWithKey (addBadOverlap localizer) [] overlaps
602766
603−findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff D.Doc)] -> [BadOverlap]
604−findBadOverlapsHelp badOverlaps fieldPairs =
605− case fieldPairs of
606− [] ->
607− badOverlaps
608767
609− (_, Similar _ _) : otherFieldPairs ->
610− findBadOverlapsHelp badOverlaps otherFieldPairs
611−
612− (field, Different aDoc bDoc problems) : otherFieldPairs ->
613− findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs
768+addBadOverlap :: L.Localizer -> N.Name -> Diff -> [BadOverlap] -> [BadOverlap]
769+addBadOverlap 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