git.iko.soy/elk
on master help sign in
Implement type diffs for records again
9a55348Evan Czaplicki
src/Type/Error.hs+158−8
compare with master
unifiedsplit
@@ -185,7 +185,8 @@ instance Applicative Diff where
185
185
186
186
187data Problem
187data Problem
188+ = FieldMismatch [N.Name] [N.Name]
188− = IntFloat
189+ | IntFloat
189 | MissingArgs Int
190 | MissingArgs Int
190 | ReturnMismatch Int Int
191 | ReturnMismatch Int Int
191 | TupleMismatch
192 | TupleMismatch
@@ -323,7 +324,7 @@ diffLambda dict ctx types1 types2 =
323--
324--
324diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
325diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
325diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
326diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
326− case toGreedyMatch dict shortRevArgs longRevArgs (GreedyMatch [] []) of
327+ case toGreedyMatch dict shortRevArgs longRevArgs of
327 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
328 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
328 let
329 let
329 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
330 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
@@ -335,7 +336,7 @@ diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
335 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
336 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
336
337
337 Nothing ->
338 Nothing ->
338− case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) (GreedyMatch [] []) of
339+ case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) of
339 Just (GreedyMatch shortArgDocs longArgDocs) ->
340 Just (GreedyMatch shortArgDocs longArgDocs) ->
340 let
341 let
341 (a:b:cs) = shortArgDocs ++ [shortResult]
342 (a:b:cs) = shortArgDocs ++ [shortResult]
@@ -368,8 +369,16 @@ data GreedyMatch =
368 GreedyMatch [H.Doc] [H.Doc]
369 GreedyMatch [H.Doc] [H.Doc]
369
370
370
371
372+--
373+-- INVARIANT: length shorterArgs < length longerArgs
374+--
375+toGreedyMatch :: Localizer -> [Type] -> [Type] -> Maybe GreedyMatch
376+toGreedyMatch dict shorterArgs longerArgs =
377+ toGreedyMatchHelp dict shorterArgs longerArgs (GreedyMatch [] [])
378+
379+
371−toGreedyMatch :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
380+toGreedyMatchHelp :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
372−toGreedyMatch dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
381+toGreedyMatchHelp dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
373 let
382 let
374 toYellowDoc tipe =
383 toYellowDoc tipe =
375 H.dullyellow (toDoc dict RT.Func tipe)
384 H.dullyellow (toDoc dict RT.Func tipe)
@@ -378,11 +387,11 @@ toGreedyMatch dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerD
378 (x:xs, y:ys) ->
387 (x:xs, y:ys) ->
379 case diff dict RT.Func x y of
388 case diff dict RT.Func x y of
380 Similar a b ->
389 Similar a b ->
381− toGreedyMatch dict xs ys $
390+ toGreedyMatchHelp dict xs ys $
382 GreedyMatch (a:shorterDocs) (b:longerDocs)
391 GreedyMatch (a:shorterDocs) (b:longerDocs)
383
392
384 Different _ _ _ ->
393 Different _ _ _ ->
385− toGreedyMatch dict shorterArgs ys $
394+ toGreedyMatchHelp dict shorterArgs ys $
386 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
395 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
387
396
388 ([], []) ->
397 ([], []) ->
@@ -401,4 +410,145 @@ toGreedyMatch dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerD
401
410
402diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
411diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
403diffRecord dict fields1 ext1 fields2 ext2 =
412diffRecord dict fields1 ext1 fields2 ext2 =
404− error "TODO" 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)
423+
424+ Different dExt1 dExt2 problems ->
425+ Different (RT.record [] dExt1) (RT.record [] dExt2) problems
426+
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))
438+
439+ else
440+ Different
441+ (toMissingDoc fields1 only1 ext1)
442+ (toMissingDoc fields2 only2 ext2)
443+ (Bag.one (FieldMismatch only1 only2))
444+
445+
446+toOverlapDoc :: (BadOverlap -> H.Doc) -> BadOverlap -> (H.Doc, H.Doc)
447+toOverlapDoc getDoc overlap@(BadOverlap field _ _ _) =
448+ (H.nameToDoc field, getDoc overlap)
449+
450+
451+toOverlapRecord :: (BadOverlap -> H.Doc) -> BadOverlap -> [BadOverlap] -> Extension -> H.Doc
452+toOverlapRecord 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)
458+
459+
460+toMissingDoc :: Map.Map N.Name t -> [N.Name] -> Extension -> H.Doc
461+toMissingDoc allFields uniqueFields ext =
462+ case map emphasizeFieldName uniqueFields of
463+ [] ->
464+ toBoringRecord allFields ext
465+
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
474+
475+
476+emphasizeFieldName :: N.Name -> (H.Doc, H.Doc)
477+emphasizeFieldName field =
478+ ( H.dullyellow (H.nameToDoc field), "..." )
479+
480+
481+toBoringRecord :: Map.Map N.Name t -> Extension -> H.Doc
482+toBoringRecord fields ext =
483+ case ext of
484+ Closed -> if Map.null fields then "{}" else "{ ... }"
485+ FlexOpen _ -> "{ ... }"
486+ RigidOpen _ -> "{ ... }"
487+
488+
489+
490+-- DIFF RECORD EXTENSION
491+
492+
493+diffExt :: Extension -> Extension -> Diff (Maybe H.Doc)
494+diffExt ext1 ext2 =
495+ let
496+ normal = Just . H.nameToDoc
497+ yellow = Just . H.dullyellow . H.nameToDoc
498+
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)
507+
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)
513+
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)))
523+
524+
525+
526+-- BAD OVERLAP
527+
528+
529+data BadOverlap =
530+ BadOverlap
531+ { _field :: N.Name
532+ , _doc1 :: H.Doc
533+ , _doc2 :: H.Doc
534+ , _problems :: Bag.Bag Problem
535+ }
536+
537+
538+findBadOverlaps :: Localizer -> Map.Map N.Name Type -> Map.Map N.Name Type -> [BadOverlap]
539+findBadOverlaps dict fields1 fields2 =
540+ findBadOverlapsHelp [] $ Map.toList $
541+ Map.intersectionWith (diff dict RT.None) fields1 fields2
542+
543+
544+findBadOverlapsHelp :: [BadOverlap] -> [(N.Name, Diff H.Doc)] -> [BadOverlap]
545+findBadOverlapsHelp badOverlaps fieldPairs =
546+ case fieldPairs of
547+ [] ->
548+ badOverlaps
549+
550+ (_, Similar _ _) : otherFieldPairs ->
551+ findBadOverlapsHelp badOverlaps otherFieldPairs
552+
553+ (field, Different aDoc bDoc problems) : otherFieldPairs ->
554+ findBadOverlapsHelp (BadOverlap field aDoc bDoc problems : badOverlaps) otherFieldPairs