From d8dc9b7d2543732c33b5161d6ed9f12f0485b234 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:25:30 -0400 Subject: [PATCH 001/118] Split Entry up into an enum in a tuple. --- src/Rendering/TOC.hs | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index a371aff3c..3af77bae7 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables, TupleSections #-} module Rendering.TOC ( renderToCDiff , diffTOC @@ -61,11 +61,11 @@ declaration (In annotation _) = annotation -- | An entry in a table of contents. -data Entry a - = Changed { entryPayload :: a } -- ^ An entry for a node containing changes. - | Inserted { entryPayload :: a } -- ^ An entry for a change occurring inside an 'Insert' 'Patch'. - | Deleted { entryPayload :: a } -- ^ An entry for a change occurring inside a 'Delete' 'Patch'. - | Replaced { entryPayload :: a } -- ^ An entry for a change occurring on the insertion side of a 'Replace' 'Patch'. +data Entry + = Changed -- ^ An entry for a node containing changes. + | Inserted -- ^ An entry for a change occurring inside an 'Insert' 'Patch'. + | Deleted -- ^ An entry for a change occurring inside a 'Delete' 'Patch'. + | Replaced -- ^ An entry for a change occurring on the insertion side of a 'Replace' 'Patch'. deriving (Eq, Show) @@ -73,13 +73,13 @@ data Entry a tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f ann ann -- ^ The diff to compute the table of contents for. - -> [Entry a] -- ^ A list of entries for relevant changed nodes in the diff. + -> [(Entry, a)] -- ^ A list of entries for relevant changed nodes in the diff. tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just [] Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of - (Just a, Just entries) -> Just (Changed a : entries) + (Just a, Just entries) -> Just ((Changed, a) : entries) (_ , entries) -> entries) - where patchEntry = patch Deleted Inserted (const Replaced) + where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) termTableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f annotation b -> Maybe a) @@ -98,30 +98,30 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- 2. Two similar entries (defined by a case insensitive comparison of their -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. -dedupe :: [Entry Declaration] -> [Entry Declaration] +dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in (fmap . fmap) snd tuples where - go :: (Int, Map.Map DedupeKey (Int, Entry Declaration)) - -> Entry Declaration - -> (Int, Map.Map DedupeKey (Int, Entry Declaration)) + go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) + -> (Entry, Declaration) + -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey x) m = if exactMatch similar x then (succ index, m) else - let replacement = Replaced (entryPayload similar) + let replacement = (Replaced, snd similar) in (succ index, Map.insert (dedupeKey replacement) (index, replacement) m) | otherwise = (succ index, Map.insert (dedupeKey x) (index, x) m) - dedupeKey entry = DedupeKey (toCategoryName (entryPayload entry), T.toLower (declarationIdentifier (entryPayload entry))) - exactMatch = (==) `on` entryPayload + dedupeKey entry = DedupeKey (toCategoryName (snd entry), T.toLower (declarationIdentifier (snd entry))) + exactMatch = (==) `on` snd -- | Construct a 'TOCSummary' from an 'Entry'. -entrySummary :: Entry Declaration -> TOCSummary +entrySummary :: (Entry, Declaration) -> TOCSummary entrySummary entry = case entry of - Changed a -> recordSummary "modified" a - Deleted a -> recordSummary "removed" a - Inserted a -> recordSummary "added" a - Replaced a -> recordSummary "modified" a + (Changed, a) -> recordSummary "modified" a + (Deleted, a) -> recordSummary "removed" a + (Inserted, a) -> recordSummary "added" a + (Replaced, a) -> recordSummary "modified" a -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: T.Text -> Declaration -> TOCSummary From 6fe1467956ff3f22b51186dda1ef162acabbbf22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:26:10 -0400 Subject: [PATCH 002/118] Monomorphize. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 3af77bae7..43ddde07b 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -140,7 +140,7 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV summaryKey = T.pack $ pathKeyForBlobPair blobs diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] -diffTOC = fmap entrySummary . dedupe . tableOfContentsBy declaration +diffTOC = map entrySummary . dedupe . tableOfContentsBy declaration -- The user-facing category name toCategoryName :: Declaration -> T.Text From 0246a2e130a085287c01c9b0b603fcabd43df808 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:26:32 -0400 Subject: [PATCH 003/118] Align. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 43ddde07b..824ffc206 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -145,7 +145,7 @@ diffTOC = map entrySummary . dedupe . tableOfContentsBy declaration -- The user-facing category name toCategoryName :: Declaration -> T.Text toCategoryName declaration = case declaration of - FunctionDeclaration{} -> "Function" - MethodDeclaration{} -> "Method" + FunctionDeclaration{} -> "Function" + MethodDeclaration{} -> "Method" HeadingDeclaration _ _ _ _ l -> "Heading " <> T.pack (show l) - ErrorDeclaration{} -> "ParseError" + ErrorDeclaration{} -> "ParseError" From fb41c1741e358a171ee5d00fa63b699218cc4bb9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:29:35 -0400 Subject: [PATCH 004/118] :fire: the export of entrySummary. --- src/Rendering/TOC.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 824ffc206..3ff006a27 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -10,7 +10,6 @@ module Rendering.TOC , tableOfContentsBy , termTableOfContentsBy , dedupe -, entrySummary , toCategoryName ) where From aa98934d8596628f63d61ac6403d72789a911501 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:29:58 -0400 Subject: [PATCH 005/118] Split the entry change type logic out of recordSummary. --- src/Rendering/TOC.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 3ff006a27..d6d904ca2 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -114,13 +114,13 @@ dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in dedupeKey entry = DedupeKey (toCategoryName (snd entry), T.toLower (declarationIdentifier (snd entry))) exactMatch = (==) `on` snd --- | Construct a 'TOCSummary' from an 'Entry'. -entrySummary :: (Entry, Declaration) -> TOCSummary -entrySummary entry = case entry of - (Changed, a) -> recordSummary "modified" a - (Deleted, a) -> recordSummary "removed" a - (Inserted, a) -> recordSummary "added" a - (Replaced, a) -> recordSummary "modified" a +-- | Construct a description of an 'Entry'. +entryChange :: Entry -> Text +entryChange entry = case entry of + Changed -> "modified" + Deleted -> "removed" + Inserted -> "added" + Replaced -> "modified" -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: T.Text -> Declaration -> TOCSummary @@ -139,7 +139,7 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV summaryKey = T.pack $ pathKeyForBlobPair blobs diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] -diffTOC = map entrySummary . dedupe . tableOfContentsBy declaration +diffTOC = map (uncurry (recordSummary . entryChange)) . dedupe . tableOfContentsBy declaration -- The user-facing category name toCategoryName :: Declaration -> T.Text From 6ced7e6fae32aea772dce0f8aa7942cb38f2e519 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:32:14 -0400 Subject: [PATCH 006/118] dedupeKey takes the second field only. --- src/Rendering/TOC.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index d6d904ca2..e03c636e2 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -103,15 +103,15 @@ dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) -> (Entry, Declaration) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey x) m + go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey (snd x)) m = if exactMatch similar x then (succ index, m) else let replacement = (Replaced, snd similar) - in (succ index, Map.insert (dedupeKey replacement) (index, replacement) m) - | otherwise = (succ index, Map.insert (dedupeKey x) (index, x) m) + in (succ index, Map.insert (dedupeKey (snd similar)) (index, replacement) m) + | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) - dedupeKey entry = DedupeKey (toCategoryName (snd entry), T.toLower (declarationIdentifier (snd entry))) + dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) exactMatch = (==) `on` snd -- | Construct a description of an 'Entry'. From bf8f03ce3769aa557745d89b3db3032b6c3f7715 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:33:43 -0400 Subject: [PATCH 007/118] :fire: a let. --- src/Rendering/TOC.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index e03c636e2..9fac2846f 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -107,8 +107,7 @@ dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in = if exactMatch similar x then (succ index, m) else - let replacement = (Replaced, snd similar) - in (succ index, Map.insert (dedupeKey (snd similar)) (index, replacement) m) + (succ index, Map.insert (dedupeKey (snd similar)) (index, (Replaced, snd similar)) m) | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) From d9505164fb03b13dd580788ba6122f259d95f16c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:34:40 -0400 Subject: [PATCH 008/118] Match the decl explicitly. --- src/Rendering/TOC.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 9fac2846f..05d4ad793 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -103,11 +103,11 @@ dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) -> (Entry, Declaration) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey (snd x)) m + go (index, m) x | Just (_, similar@(_, similarDecl)) <- Map.lookup (dedupeKey (snd x)) m = if exactMatch similar x then (succ index, m) else - (succ index, Map.insert (dedupeKey (snd similar)) (index, (Replaced, snd similar)) m) + (succ index, Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m) | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) From 70414495f56dad0de5f0410bca3aec1d77cc58f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:35:17 -0400 Subject: [PATCH 009/118] :fire: exactMatch. --- src/Rendering/TOC.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 05d4ad793..4db405a83 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -103,15 +103,14 @@ dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) -> (Entry, Declaration) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - go (index, m) x | Just (_, similar@(_, similarDecl)) <- Map.lookup (dedupeKey (snd x)) m - = if exactMatch similar x + go (index, m) x | Just (_, (_, similarDecl)) <- Map.lookup (dedupeKey (snd x)) m + = if similarDecl == snd x then (succ index, m) else (succ index, Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m) | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) - exactMatch = (==) `on` snd -- | Construct a description of an 'Entry'. entryChange :: Entry -> Text From b54d10931170203ddce4c48b4140173862542947 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:35:46 -0400 Subject: [PATCH 010/118] Move tuples into the where clause. --- src/Rendering/TOC.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 4db405a83..1e5bad38f 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -98,8 +98,9 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in (fmap . fmap) snd tuples +dedupe = (fmap . fmap) snd tuples where + tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) -> (Entry, Declaration) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) From a2348e3463356d07170389238b789a013ee6254f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:38:41 -0400 Subject: [PATCH 011/118] Monomorphize. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 1e5bad38f..faaec7319 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -98,7 +98,7 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = (fmap . fmap) snd tuples +dedupe = fmap (map snd) tuples where tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) From a488ec2d9f12d095b5d2ac0ee222b97031391e22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:39:08 -0400 Subject: [PATCH 012/118] Compose. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index faaec7319..75201cfcc 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -98,7 +98,7 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = fmap (map snd) tuples +dedupe = map snd . tuples where tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) From 582d516bf4079c771d088b029dfb70391688adb2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:39:21 -0400 Subject: [PATCH 013/118] Inline tuples. --- src/Rendering/TOC.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 75201cfcc..abc50b66c 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -98,9 +98,8 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map snd . tuples +dedupe = map snd . sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) where - tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) -> (Entry, Declaration) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) From bfec2ffa45e8c15e1fc6e2d7e9a17d70e0d01514 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:40:20 -0400 Subject: [PATCH 014/118] Reformat go. --- src/Rendering/TOC.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index abc50b66c..52a907898 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -103,12 +103,13 @@ dedupe = map snd . sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) -> (Entry, Declaration) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - go (index, m) x | Just (_, (_, similarDecl)) <- Map.lookup (dedupeKey (snd x)) m - = if similarDecl == snd x - then (succ index, m) - else - (succ index, Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m) - | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) + go (index, m) x + | Just (_, (_, similarDecl)) <- Map.lookup (dedupeKey (snd x)) m + = if similarDecl == snd x then + (succ index, m) + else + (succ index, Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m) + | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) From 50638e0205b32a0b43043cf44afb6ba2227a53e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:40:57 -0400 Subject: [PATCH 015/118] Factor out the tuple. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 52a907898..6b4f1b758 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -105,10 +105,10 @@ dedupe = map snd . sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) go (index, m) x | Just (_, (_, similarDecl)) <- Map.lookup (dedupeKey (snd x)) m - = if similarDecl == snd x then - (succ index, m) + = (succ index,) $ if similarDecl == snd x then + m else - (succ index, Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m) + Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) From 483e6b2f2c713789855a8b574a84243a32cdc3cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:42:13 -0400 Subject: [PATCH 016/118] Curry go. --- src/Rendering/TOC.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 6b4f1b758..16a53aa3d 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -98,18 +98,19 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map snd . sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) +dedupe = map snd . sortOn fst . Map.elems . snd . foldl' (uncurry . go) (0, Map.empty) where go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - -> (Entry, Declaration) + -> Entry + -> Declaration -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - go (index, m) x - | Just (_, (_, similarDecl)) <- Map.lookup (dedupeKey (snd x)) m - = (succ index,) $ if similarDecl == snd x then + go (index, m) entry decl + | Just (_, (_, similarDecl)) <- Map.lookup (dedupeKey decl) m + = (succ index,) $ if similarDecl == decl then m else Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m - | otherwise = (succ index, Map.insert (dedupeKey (snd x)) (index, x) m) + | otherwise = (succ index, Map.insert (dedupeKey decl) (index, (entry, decl)) m) dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) From 6f7683c9a727f3b4207eee6aa8b4713d383b2142 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:45:17 -0400 Subject: [PATCH 017/118] :fire: redundant parens. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 16a53aa3d..03552b56a 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -125,7 +125,7 @@ entryChange entry = case entry of -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: T.Text -> Declaration -> TOCSummary recordSummary changeText record = case record of - (ErrorDeclaration text _ srcSpan language) -> ErrorSummary text srcSpan language + ErrorDeclaration text _ srcSpan language -> ErrorSummary text srcSpan language decl-> TOCSummary (toCategoryName decl) (formatIdentifier decl) (declarationSpan decl) changeText where formatIdentifier (MethodDeclaration identifier _ _ Language.Go (Just receiver)) = "(" <> receiver <> ") " <> identifier From 3a3145050c5cae2e5fe0d3afaf8c6fb7c7501e6a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:45:27 -0400 Subject: [PATCH 018/118] Spacing. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 03552b56a..c498d19f9 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -126,7 +126,7 @@ entryChange entry = case entry of recordSummary :: T.Text -> Declaration -> TOCSummary recordSummary changeText record = case record of ErrorDeclaration text _ srcSpan language -> ErrorSummary text srcSpan language - decl-> TOCSummary (toCategoryName decl) (formatIdentifier decl) (declarationSpan decl) changeText + decl -> TOCSummary (toCategoryName decl) (formatIdentifier decl) (declarationSpan decl) changeText where formatIdentifier (MethodDeclaration identifier _ _ Language.Go (Just receiver)) = "(" <> receiver <> ") " <> identifier formatIdentifier (MethodDeclaration identifier _ _ _ (Just receiver)) = receiver <> "." <> identifier From 10e82079b9900126bd6747d6b5dda8e0228e77a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 17:54:48 -0400 Subject: [PATCH 019/118] :fire: the Generic instance for Declaration. --- src/Analysis/TOCSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index d8045fa40..a4cde900a 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -28,7 +28,7 @@ data Declaration | FunctionDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language } | HeadingDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int } | ErrorDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language } - deriving (Eq, Generic, Show) + deriving (Eq, Show) -- | An r-algebra producing 'Just' a 'Declaration' for syntax nodes corresponding to high-level declarations, or 'Nothing' otherwise. From ab0781c07a02a718438c510100967ea8c0903a3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:00:05 -0400 Subject: [PATCH 020/118] Factor Declaration into a kind and the rest of the fields. --- src/Analysis/TOCSummary.hs | 31 ++++++++++++++++++++----------- src/Rendering/TOC.hs | 22 +++++++++++----------- 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index a4cde900a..1660c676e 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.TOCSummary ( Declaration(..) +, DeclarationKind(..) , HasDeclaration , declarationAlgebra ) where @@ -23,11 +24,19 @@ import Source.Range import qualified Language.Markdown.Syntax as Markdown -- | A declaration’s identifier and type. -data Declaration - = MethodDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationReceiver :: Maybe Text } - | FunctionDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language } - | HeadingDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int } - | ErrorDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language } +data Declaration = Declaration + { declarationKind :: DeclarationKind + , declarationIdentifier :: Text + , declarationText :: Text + , declarationSpan :: Span + , declarationLanguage :: Language } + deriving (Eq, Show) + +data DeclarationKind + = MethodDeclaration (Maybe Text) + | FunctionDeclaration + | HeadingDeclaration Int + | ErrorDeclaration deriving (Eq, Show) @@ -77,7 +86,7 @@ class CustomHasDeclaration whole syntax where -- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node. instance CustomHasDeclaration whole Markdown.Heading where customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _) - = Just $ HeadingDeclaration (headingText terms) mempty (Loc.span ann) (blobLanguage blob) level + = Just $ Declaration (HeadingDeclaration level) (headingText terms) mempty (Loc.span ann) (blobLanguage blob) where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms)) headingByteRange (Term (In ann _), _) = byteRange ann getSource = firstLine . toText . Source.slice blobSource @@ -86,7 +95,7 @@ instance CustomHasDeclaration whole Markdown.Heading where -- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes. instance CustomHasDeclaration whole Syntax.Error where customToDeclaration blob@Blob{..} ann err@Syntax.Error{} - = Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) + = Just $ Declaration ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) "" -- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). @@ -95,7 +104,7 @@ instance CustomHasDeclaration whole Declaration.Function where -- Do not summarize anonymous functions | isEmpty identifierAnn = Nothing -- Named functions - | otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (Loc.span ann) (blobLanguage blob) + | otherwise = Just $ Declaration FunctionDeclaration (getSource blobSource identifierAnn) functionSource (Loc.span ann) (blobLanguage blob) where isEmpty = (== 0) . rangeLength . byteRange functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl) @@ -103,12 +112,12 @@ instance CustomHasDeclaration whole Declaration.Function where instance CustomHasDeclaration whole Declaration.Method where customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) -- Methods without a receiver - | isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) Nothing + | isEmpty receiverAnn = Just $ Declaration (MethodDeclaration Nothing) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go). | blobLanguage blob == Go - , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) (Just (getSource blobSource receiverType)) + , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ Declaration (MethodDeclaration (Just (getSource blobSource receiverType))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) -- Methods with a receiver (class methods) are formatted like `receiver.method_name` - | otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) (Just (getSource blobSource receiverAnn)) + | otherwise = Just $ Declaration (MethodDeclaration (Just (getSource blobSource receiverAnn))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) where isEmpty = (== 0) . rangeLength . byteRange methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index c498d19f9..9209ee4d5 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -112,7 +112,7 @@ dedupe = map snd . sortOn fst . Map.elems . snd . foldl' (uncurry . go) (0, Map. Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m | otherwise = (succ index, Map.insert (dedupeKey decl) (index, (entry, decl)) m) - dedupeKey decl = DedupeKey (toCategoryName decl, T.toLower (declarationIdentifier decl)) + dedupeKey decl = DedupeKey (toCategoryName (declarationKind decl), T.toLower (declarationIdentifier decl)) -- | Construct a description of an 'Entry'. entryChange :: Entry -> Text @@ -125,11 +125,11 @@ entryChange entry = case entry of -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: T.Text -> Declaration -> TOCSummary recordSummary changeText record = case record of - ErrorDeclaration text _ srcSpan language -> ErrorSummary text srcSpan language - decl -> TOCSummary (toCategoryName decl) (formatIdentifier decl) (declarationSpan decl) changeText + Declaration ErrorDeclaration text _ srcSpan language -> ErrorSummary text srcSpan language + decl -> TOCSummary (toCategoryName (declarationKind decl)) (formatIdentifier decl) (declarationSpan decl) changeText where - formatIdentifier (MethodDeclaration identifier _ _ Language.Go (Just receiver)) = "(" <> receiver <> ") " <> identifier - formatIdentifier (MethodDeclaration identifier _ _ _ (Just receiver)) = receiver <> "." <> identifier + formatIdentifier (Declaration (MethodDeclaration (Just receiver)) identifier _ _ Language.Go) = "(" <> receiver <> ") " <> identifier + formatIdentifier (Declaration (MethodDeclaration (Just receiver)) identifier _ _ _ ) = receiver <> "." <> identifier formatIdentifier decl = declarationIdentifier decl renderToCDiff :: (Foldable f, Functor f) => BlobPair -> Diff f (Maybe Declaration) (Maybe Declaration) -> Summaries @@ -142,9 +142,9 @@ diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declarat diffTOC = map (uncurry (recordSummary . entryChange)) . dedupe . tableOfContentsBy declaration -- The user-facing category name -toCategoryName :: Declaration -> T.Text -toCategoryName declaration = case declaration of - FunctionDeclaration{} -> "Function" - MethodDeclaration{} -> "Method" - HeadingDeclaration _ _ _ _ l -> "Heading " <> T.pack (show l) - ErrorDeclaration{} -> "ParseError" +toCategoryName :: DeclarationKind -> T.Text +toCategoryName kind = case kind of + FunctionDeclaration -> "Function" + MethodDeclaration _ -> "Method" + HeadingDeclaration l -> "Heading " <> T.pack (show l) + ErrorDeclaration -> "ParseError" From a0d9f57239d60c7fa05ee6237107943771178607 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:00:52 -0400 Subject: [PATCH 021/118] Pattern match in dedupeKey. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 9209ee4d5..bfbc5bdf8 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -112,7 +112,7 @@ dedupe = map snd . sortOn fst . Map.elems . snd . foldl' (uncurry . go) (0, Map. Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m | otherwise = (succ index, Map.insert (dedupeKey decl) (index, (entry, decl)) m) - dedupeKey decl = DedupeKey (toCategoryName (declarationKind decl), T.toLower (declarationIdentifier decl)) + dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) -- | Construct a description of an 'Entry'. entryChange :: Entry -> Text From be95b43b71a4994964e7bef70f221d739dd5e802 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:03:13 -0400 Subject: [PATCH 022/118] Reformat formatIdentifier. --- src/Rendering/TOC.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index bfbc5bdf8..d82475676 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -128,9 +128,11 @@ recordSummary changeText record = case record of Declaration ErrorDeclaration text _ srcSpan language -> ErrorSummary text srcSpan language decl -> TOCSummary (toCategoryName (declarationKind decl)) (formatIdentifier decl) (declarationSpan decl) changeText where - formatIdentifier (Declaration (MethodDeclaration (Just receiver)) identifier _ _ Language.Go) = "(" <> receiver <> ") " <> identifier - formatIdentifier (Declaration (MethodDeclaration (Just receiver)) identifier _ _ _ ) = receiver <> "." <> identifier - formatIdentifier decl = declarationIdentifier decl + formatIdentifier (Declaration kind identifier _ _ lang) = case kind of + MethodDeclaration (Just receiver) + | Language.Go <- lang -> "(" <> receiver <> ") " <> identifier + | otherwise -> receiver <> "." <> identifier + _ -> identifier renderToCDiff :: (Foldable f, Functor f) => BlobPair -> Diff f (Maybe Declaration) (Maybe Declaration) -> Summaries renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC From 73713125cd626c29e75068b939f719a39c9114e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:04:08 -0400 Subject: [PATCH 023/118] Extract formatIdentifier to the top level. --- src/Rendering/TOC.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index d82475676..dff9e9b94 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -127,12 +127,13 @@ recordSummary :: T.Text -> Declaration -> TOCSummary recordSummary changeText record = case record of Declaration ErrorDeclaration text _ srcSpan language -> ErrorSummary text srcSpan language decl -> TOCSummary (toCategoryName (declarationKind decl)) (formatIdentifier decl) (declarationSpan decl) changeText - where - formatIdentifier (Declaration kind identifier _ _ lang) = case kind of - MethodDeclaration (Just receiver) - | Language.Go <- lang -> "(" <> receiver <> ") " <> identifier - | otherwise -> receiver <> "." <> identifier - _ -> identifier + +formatIdentifier :: Declaration -> Text +formatIdentifier (Declaration kind identifier _ _ lang) = case kind of + MethodDeclaration (Just receiver) + | Language.Go <- lang -> "(" <> receiver <> ") " <> identifier + | otherwise -> receiver <> "." <> identifier + _ -> identifier renderToCDiff :: (Foldable f, Functor f) => BlobPair -> Diff f (Maybe Declaration) (Maybe Declaration) -> Summaries renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC From 203ea9c954e70c980e9bd445a715e2b257d3abe8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:05:51 -0400 Subject: [PATCH 024/118] Define recordSummary using guards. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index dff9e9b94..63fa64150 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -124,9 +124,9 @@ entryChange entry = case entry of -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: T.Text -> Declaration -> TOCSummary -recordSummary changeText record = case record of - Declaration ErrorDeclaration text _ srcSpan language -> ErrorSummary text srcSpan language - decl -> TOCSummary (toCategoryName (declarationKind decl)) (formatIdentifier decl) (declarationSpan decl) changeText +recordSummary changeText decl@(Declaration kind text _ srcSpan language) + | ErrorDeclaration <- kind = ErrorSummary text srcSpan language + | otherwise = TOCSummary (toCategoryName kind) (formatIdentifier decl) srcSpan changeText formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of From e084c83b7fa5d751fb01d0459f21167e353379d0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:11:24 -0400 Subject: [PATCH 025/118] Alignment. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 63fa64150..be404634b 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -86,7 +86,7 @@ termTableOfContentsBy :: (Foldable f, Functor f) -> [a] termTableOfContentsBy selector = cata termAlgebra where termAlgebra r | Just a <- selector r = a : fold r - | otherwise = fold r + | otherwise = fold r newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) From fba58c685f92d60f8781f33a6188fa402f6b4151 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:12:40 -0400 Subject: [PATCH 026/118] :fire: termTableOfContentsBy. --- src/Rendering/TOC.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index be404634b..47d620b28 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -8,7 +8,6 @@ module Rendering.TOC , declaration , Entry(..) , tableOfContentsBy -, termTableOfContentsBy , dedupe , toCategoryName ) where @@ -80,13 +79,6 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of (_ , entries) -> entries) where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) -termTableOfContentsBy :: (Foldable f, Functor f) - => (forall b. TermF f annotation b -> Maybe a) - -> Term f annotation - -> [a] -termTableOfContentsBy selector = cata termAlgebra - where termAlgebra r | Just a <- selector r = a : fold r - | otherwise = fold r newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) From 2523d60b2c9a3c6e8b43b98442ec4ae0f4a3f509 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:13:14 -0400 Subject: [PATCH 027/118] Rename similarDecl to similar. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 47d620b28..7b6951795 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -97,11 +97,11 @@ dedupe = map snd . sortOn fst . Map.elems . snd . foldl' (uncurry . go) (0, Map. -> Declaration -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) go (index, m) entry decl - | Just (_, (_, similarDecl)) <- Map.lookup (dedupeKey decl) m - = (succ index,) $ if similarDecl == decl then + | Just (_, (_, similar)) <- Map.lookup (dedupeKey decl) m + = (succ index,) $ if similar == decl then m else - Map.insert (dedupeKey similarDecl) (index, (Replaced, similarDecl)) m + Map.insert (dedupeKey similar) (index, (Replaced, similar)) m | otherwise = (succ index, Map.insert (dedupeKey decl) (index, (entry, decl)) m) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) From ce0866dc1b96203c84bbc353137529864584cbd2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:14:27 -0400 Subject: [PATCH 028/118] Uncurry go. --- src/Rendering/TOC.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 7b6951795..d1bbfe7b3 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -90,13 +90,12 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map snd . sortOn fst . Map.elems . snd . foldl' (uncurry . go) (0, Map.empty) +dedupe = map snd . sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) where go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - -> Entry - -> Declaration + -> (Entry, Declaration) -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - go (index, m) entry decl + go (index, m) (entry, decl) | Just (_, (_, similar)) <- Map.lookup (dedupeKey decl) m = (succ index,) $ if similar == decl then m From 444f0b306ce00014d696c402b3c465c29a16a494 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:15:37 -0400 Subject: [PATCH 029/118] Index the elements, not the fold. --- src/Rendering/TOC.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index d1bbfe7b3..b777399f1 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -90,18 +90,18 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map snd . sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) +dedupe = map snd . sortOn fst . Map.elems . foldl' go Map.empty . zip [0..] where - go :: (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - -> (Entry, Declaration) - -> (Int, Map.Map DedupeKey (Int, (Entry, Declaration))) - go (index, m) (entry, decl) + go :: Map.Map DedupeKey (Int, (Entry, Declaration)) + -> (Int, (Entry, Declaration)) + -> Map.Map DedupeKey (Int, (Entry, Declaration)) + go m (index, (entry, decl)) | Just (_, (_, similar)) <- Map.lookup (dedupeKey decl) m - = (succ index,) $ if similar == decl then + = if similar == decl then m else Map.insert (dedupeKey similar) (index, (Replaced, similar)) m - | otherwise = (succ index, Map.insert (dedupeKey decl) (index, (entry, decl)) m) + | otherwise = Map.insert (dedupeKey decl) (index, (entry, decl)) m dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) From f366d4519d31164958a3e46d8dafb8d3466afe2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:16:59 -0400 Subject: [PATCH 030/118] Extract a helper to find a similar entry. --- src/Rendering/TOC.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index b777399f1..1b2211fae 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -96,13 +96,14 @@ dedupe = map snd . sortOn fst . Map.elems . foldl' go Map.empty . zip [0..] -> (Int, (Entry, Declaration)) -> Map.Map DedupeKey (Int, (Entry, Declaration)) go m (index, (entry, decl)) - | Just (_, (_, similar)) <- Map.lookup (dedupeKey decl) m + | Just (_, (_, similar)) <- findSimilar decl m = if similar == decl then m else Map.insert (dedupeKey similar) (index, (Replaced, similar)) m | otherwise = Map.insert (dedupeKey decl) (index, (entry, decl)) m + findSimilar decl = Map.lookup (dedupeKey decl) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) -- | Construct a description of an 'Entry'. From 8b4c045e0d6c529bff8f43b6fc5018e401828be1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:19:32 -0400 Subject: [PATCH 031/118] Define go as a case expression. --- src/Rendering/TOC.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 1b2211fae..2caf1535a 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -95,13 +95,11 @@ dedupe = map snd . sortOn fst . Map.elems . foldl' go Map.empty . zip [0..] go :: Map.Map DedupeKey (Int, (Entry, Declaration)) -> (Int, (Entry, Declaration)) -> Map.Map DedupeKey (Int, (Entry, Declaration)) - go m (index, (entry, decl)) - | Just (_, (_, similar)) <- findSimilar decl m - = if similar == decl then - m - else - Map.insert (dedupeKey similar) (index, (Replaced, similar)) m - | otherwise = Map.insert (dedupeKey decl) (index, (entry, decl)) m + go m (index, (entry, decl)) = case findSimilar decl m of + Just (_, (_, similar)) + | similar == decl -> m + | otherwise -> Map.insert (dedupeKey similar) (index, (Replaced, similar)) m + _ -> Map.insert (dedupeKey decl) (index, (entry, decl)) m findSimilar decl = Map.lookup (dedupeKey decl) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) From 978b406be27df2d5d7c6cf66cf8ebda381f2f11f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:20:57 -0400 Subject: [PATCH 032/118] =?UTF-8?q?Don=E2=80=99t=20match=20the=20index=20&?= =?UTF-8?q?=20entry.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 2caf1535a..05a9fad29 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -95,11 +95,11 @@ dedupe = map snd . sortOn fst . Map.elems . foldl' go Map.empty . zip [0..] go :: Map.Map DedupeKey (Int, (Entry, Declaration)) -> (Int, (Entry, Declaration)) -> Map.Map DedupeKey (Int, (Entry, Declaration)) - go m (index, (entry, decl)) = case findSimilar decl m of + go m x@(_, (_, decl)) = case findSimilar decl m of Just (_, (_, similar)) | similar == decl -> m - | otherwise -> Map.insert (dedupeKey similar) (index, (Replaced, similar)) m - _ -> Map.insert (dedupeKey decl) (index, (entry, decl)) m + | otherwise -> Map.insert (dedupeKey similar) ((Replaced, similar) <$ x) m + _ -> Map.insert (dedupeKey decl) x m findSimilar decl = Map.lookup (dedupeKey decl) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) From b3e49380c70d73f871737a61a3ad2c011fd3fc76 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:26:10 -0400 Subject: [PATCH 033/118] Use strict triples in the maps. --- src/Rendering/TOC.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 05a9fad29..8da8baae8 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -82,6 +82,12 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) +data Dedupe = Dedupe + { dedupeIndex :: {-# UNPACK #-} !Int + , dedupeEntry :: {-# UNPACK #-} !Entry + , dedupeDecl :: {-# UNPACK #-} !Declaration + } + -- Dedupe entries in a final pass. This catches two specific scenarios with -- different behaviors: -- 1. Identical entries are in the list. @@ -90,16 +96,16 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map snd . sortOn fst . Map.elems . foldl' go Map.empty . zip [0..] +dedupe = map (dedupeEntry &&& dedupeDecl) . sortOn dedupeIndex . Map.elems . foldl' go Map.empty . zip [0..] where - go :: Map.Map DedupeKey (Int, (Entry, Declaration)) + go :: Map.Map DedupeKey Dedupe -> (Int, (Entry, Declaration)) - -> Map.Map DedupeKey (Int, (Entry, Declaration)) - go m x@(_, (_, decl)) = case findSimilar decl m of - Just (_, (_, similar)) + -> Map.Map DedupeKey Dedupe + go m (index, (entry, decl)) = case findSimilar decl m of + Just (Dedupe _ _ similar) | similar == decl -> m - | otherwise -> Map.insert (dedupeKey similar) ((Replaced, similar) <$ x) m - _ -> Map.insert (dedupeKey decl) x m + | otherwise -> Map.insert (dedupeKey similar) (Dedupe index Replaced similar) m + _ -> Map.insert (dedupeKey decl) (Dedupe index entry decl) m findSimilar decl = Map.lookup (dedupeKey decl) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) From b2bbe03e851aa30e55eb8748db94bbc37e40d7fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:27:05 -0400 Subject: [PATCH 034/118] Map the entries into Dedupe. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 8da8baae8..b816b738f 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -96,12 +96,12 @@ data Dedupe = Dedupe -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map (dedupeEntry &&& dedupeDecl) . sortOn dedupeIndex . Map.elems . foldl' go Map.empty . zip [0..] +dedupe = map (dedupeEntry &&& dedupeDecl) . sortOn dedupeIndex . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where go :: Map.Map DedupeKey Dedupe - -> (Int, (Entry, Declaration)) + -> Dedupe -> Map.Map DedupeKey Dedupe - go m (index, (entry, decl)) = case findSimilar decl m of + go m (Dedupe index entry decl) = case findSimilar decl m of Just (Dedupe _ _ similar) | similar == decl -> m | otherwise -> Map.insert (dedupeKey similar) (Dedupe index Replaced similar) m From ca4247d6af2c1d421568c6e59ed90fff674f0fc1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:27:18 -0400 Subject: [PATCH 035/118] :fire: the signature for go. --- src/Rendering/TOC.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index b816b738f..437b46116 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -98,9 +98,6 @@ data Dedupe = Dedupe dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] dedupe = map (dedupeEntry &&& dedupeDecl) . sortOn dedupeIndex . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where - go :: Map.Map DedupeKey Dedupe - -> Dedupe - -> Map.Map DedupeKey Dedupe go m (Dedupe index entry decl) = case findSimilar decl m of Just (Dedupe _ _ similar) | similar == decl -> m From c94e53adf97e264bacfb64b938e7c1a7db0d7240 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:28:11 -0400 Subject: [PATCH 036/118] =?UTF-8?q?Don=E2=80=99t=20repack=20Dedupe=20when?= =?UTF-8?q?=20we=20don=E2=80=99t=20have=20to.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 437b46116..e3915398e 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -98,11 +98,11 @@ data Dedupe = Dedupe dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] dedupe = map (dedupeEntry &&& dedupeDecl) . sortOn dedupeIndex . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where - go m (Dedupe index entry decl) = case findSimilar decl m of + go m d@(Dedupe _ _ decl) = case findSimilar decl m of Just (Dedupe _ _ similar) | similar == decl -> m - | otherwise -> Map.insert (dedupeKey similar) (Dedupe index Replaced similar) m - _ -> Map.insert (dedupeKey decl) (Dedupe index entry decl) m + | otherwise -> Map.insert (dedupeKey similar) (d { dedupeEntry = Replaced, dedupeDecl = similar }) m + _ -> Map.insert (dedupeKey decl) d m findSimilar decl = Map.lookup (dedupeKey decl) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) From 94099aad8fb9018a4c1efa321ccff65e90dca4e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:29:47 -0400 Subject: [PATCH 037/118] =?UTF-8?q?Don=E2=80=99t=20prefix=20the=20Dedupe?= =?UTF-8?q?=20fields.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rendering/TOC.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index e3915398e..1322d00b9 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -12,7 +12,7 @@ module Rendering.TOC , toCategoryName ) where -import Prologue +import Prologue hiding (index) import Analysis.TOCSummary import Data.Align (bicrosswalk) import Data.Aeson @@ -83,9 +83,9 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) data Dedupe = Dedupe - { dedupeIndex :: {-# UNPACK #-} !Int - , dedupeEntry :: {-# UNPACK #-} !Entry - , dedupeDecl :: {-# UNPACK #-} !Declaration + { index :: {-# UNPACK #-} !Int + , entry :: {-# UNPACK #-} !Entry + , decl :: {-# UNPACK #-} !Declaration } -- Dedupe entries in a final pass. This catches two specific scenarios with @@ -96,12 +96,12 @@ data Dedupe = Dedupe -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map (dedupeEntry &&& dedupeDecl) . sortOn dedupeIndex . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] +dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where go m d@(Dedupe _ _ decl) = case findSimilar decl m of Just (Dedupe _ _ similar) | similar == decl -> m - | otherwise -> Map.insert (dedupeKey similar) (d { dedupeEntry = Replaced, dedupeDecl = similar }) m + | otherwise -> Map.insert (dedupeKey similar) (d { entry = Replaced, decl = similar }) m _ -> Map.insert (dedupeKey decl) d m findSimilar decl = Map.lookup (dedupeKey decl) From 8519e25b26c09e97c0d8bd2a1fb3e0638be4d2c9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:30:56 -0400 Subject: [PATCH 038/118] Call entryChange from recordSummary. --- src/Rendering/TOC.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 1322d00b9..04185e3a9 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -116,10 +116,10 @@ entryChange entry = case entry of Replaced -> "modified" -- | Construct a 'TOCSummary' from a node annotation and a change type label. -recordSummary :: T.Text -> Declaration -> TOCSummary -recordSummary changeText decl@(Declaration kind text _ srcSpan language) +recordSummary :: Entry -> Declaration -> TOCSummary +recordSummary entry decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language - | otherwise = TOCSummary (toCategoryName kind) (formatIdentifier decl) srcSpan changeText + | otherwise = TOCSummary (toCategoryName kind) (formatIdentifier decl) srcSpan (entryChange entry) formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of @@ -135,7 +135,7 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV summaryKey = T.pack $ pathKeyForBlobPair blobs diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] -diffTOC = map (uncurry (recordSummary . entryChange)) . dedupe . tableOfContentsBy declaration +diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration -- The user-facing category name toCategoryName :: DeclarationKind -> T.Text From fe1de046b0664ca4689764ba83af3b04d948ec21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:35:00 -0400 Subject: [PATCH 039/118] findSimilar returns just the similar Declaration. --- src/Rendering/TOC.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 04185e3a9..0c26236cd 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -99,12 +99,12 @@ dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where go m d@(Dedupe _ _ decl) = case findSimilar decl m of - Just (Dedupe _ _ similar) + Just similar | similar == decl -> m | otherwise -> Map.insert (dedupeKey similar) (d { entry = Replaced, decl = similar }) m _ -> Map.insert (dedupeKey decl) d m - findSimilar decl = Map.lookup (dedupeKey decl) + findSimilar d = fmap decl . Map.lookup (dedupeKey d) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) -- | Construct a description of an 'Entry'. From a0fbf8433e0e9af7a420007825b88b58966eb198 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:35:36 -0400 Subject: [PATCH 040/118] :fire: redundant parens. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 0c26236cd..e426a2f3a 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -101,7 +101,7 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . go m d@(Dedupe _ _ decl) = case findSimilar decl m of Just similar | similar == decl -> m - | otherwise -> Map.insert (dedupeKey similar) (d { entry = Replaced, decl = similar }) m + | otherwise -> Map.insert (dedupeKey similar) d { entry = Replaced, decl = similar } m _ -> Map.insert (dedupeKey decl) d m findSimilar d = fmap decl . Map.lookup (dedupeKey d) From 83a84e0d226f397720cf67488cd9b56c140ec7a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:35:52 -0400 Subject: [PATCH 041/118] Alignment. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index e426a2f3a..b7d488d28 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -102,7 +102,7 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . Just similar | similar == decl -> m | otherwise -> Map.insert (dedupeKey similar) d { entry = Replaced, decl = similar } m - _ -> Map.insert (dedupeKey decl) d m + _ -> Map.insert (dedupeKey decl) d m findSimilar d = fmap decl . Map.lookup (dedupeKey d) dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) From f8a24c4c4d0e695b7db4cd26200cc4f47c3adb9a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:36:09 -0400 Subject: [PATCH 042/118] Reformat. --- src/Rendering/TOC.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index b7d488d28..5c029c33d 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -96,16 +96,15 @@ data Dedupe = Dedupe -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] -dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] - where - go m d@(Dedupe _ _ decl) = case findSimilar decl m of - Just similar - | similar == decl -> m - | otherwise -> Map.insert (dedupeKey similar) d { entry = Replaced, decl = similar } m - _ -> Map.insert (dedupeKey decl) d m +dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where + go m d@(Dedupe _ _ decl) = case findSimilar decl m of + Just similar + | similar == decl -> m + | otherwise -> Map.insert (dedupeKey similar) d { entry = Replaced, decl = similar } m + _ -> Map.insert (dedupeKey decl) d m - findSimilar d = fmap decl . Map.lookup (dedupeKey d) - dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) + findSimilar d = fmap decl . Map.lookup (dedupeKey d) + dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) -- | Construct a description of an 'Entry'. entryChange :: Entry -> Text From a98588bf29ba2a0a2e8bd418830980abbc71dd6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:39:07 -0400 Subject: [PATCH 043/118] =?UTF-8?q?Don=E2=80=99t=20recompute=20the=20key.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rendering/TOC.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 5c029c33d..72944c6aa 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -97,13 +97,13 @@ data Dedupe = Dedupe -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where - go m d@(Dedupe _ _ decl) = case findSimilar decl m of + go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case findSimilarBy key m of Just similar | similar == decl -> m - | otherwise -> Map.insert (dedupeKey similar) d { entry = Replaced, decl = similar } m - _ -> Map.insert (dedupeKey decl) d m + | otherwise -> Map.insert key d { entry = Replaced, decl = similar } m + _ -> Map.insert key d m - findSimilar d = fmap decl . Map.lookup (dedupeKey d) + findSimilarBy key = fmap decl . Map.lookup key dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) -- | Construct a description of an 'Entry'. From 9dbb0198332494e53ff1a286b4465fa8f2fdee24 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:39:32 -0400 Subject: [PATCH 044/118] :fire: findSimilarBy. --- src/Rendering/TOC.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 72944c6aa..e10485b66 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -97,13 +97,12 @@ data Dedupe = Dedupe -- Action: Combine them into a single Replaced entry. dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where - go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case findSimilarBy key m of - Just similar + go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case Map.lookup key m of + Just (Dedupe _ _ similar) | similar == decl -> m | otherwise -> Map.insert key d { entry = Replaced, decl = similar } m _ -> Map.insert key d m - findSimilarBy key = fmap decl . Map.lookup key dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) -- | Construct a description of an 'Entry'. From b99dc6ad23b0fe30b1172f9b97875369e3ed9b9c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:41:10 -0400 Subject: [PATCH 045/118] Unpack DedupeKey. --- src/Rendering/TOC.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index e10485b66..a1dc6b6ac 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -80,7 +80,8 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) -newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) +data DedupeKey = DedupeKey {-# UNPACK #-} !T.Text {-# UNPACK #-} !T.Text + deriving (Eq, Ord) data Dedupe = Dedupe { index :: {-# UNPACK #-} !Int @@ -103,7 +104,7 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . | otherwise -> Map.insert key d { entry = Replaced, decl = similar } m _ -> Map.insert key d m - dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind, T.toLower ident) + dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind) (T.toLower ident) -- | Construct a description of an 'Entry'. entryChange :: Entry -> Text From 220c6dd133ad00aa49fafd549acde85b322931d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:42:57 -0400 Subject: [PATCH 046/118] Rename the Declaration fields. --- src/Analysis/TOCSummary.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 1660c676e..33875fab6 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -25,11 +25,11 @@ import qualified Language.Markdown.Syntax as Markdown -- | A declaration’s identifier and type. data Declaration = Declaration - { declarationKind :: DeclarationKind - , declarationIdentifier :: Text - , declarationText :: Text - , declarationSpan :: Span - , declarationLanguage :: Language } + { kind :: DeclarationKind + , identifier :: Text + , text :: Text + , span :: Span + , language :: Language } deriving (Eq, Show) data DeclarationKind @@ -108,7 +108,7 @@ instance CustomHasDeclaration whole Declaration.Function where where isEmpty = (== 0) . rangeLength . byteRange functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl) --- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'declarationIdentifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. +-- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. instance CustomHasDeclaration whole Declaration.Method where customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) -- Methods without a receiver @@ -123,7 +123,7 @@ instance CustomHasDeclaration whole Declaration.Method where methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl) -- When encountering a Declaration-annotated term, we need to extract a Text --- for the resulting Declaration's 'declarationIdentifier' field. This text +-- for the resulting Declaration's 'identifier' field. This text -- is constructed by slicing out text from the original blob corresponding -- to a location, which is found via the passed-in rule. getIdentifier :: Functor m From 1242180ccc7192bd82b2172bcbd2eaa1843886c1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:46:16 -0400 Subject: [PATCH 047/118] =?UTF-8?q?Don=E2=80=99t=20export=20toCategoryName?= =?UTF-8?q?.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rendering/TOC.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index a1dc6b6ac..326cd7b64 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -9,7 +9,6 @@ module Rendering.TOC , Entry(..) , tableOfContentsBy , dedupe -, toCategoryName ) where import Prologue hiding (index) From 0531d03f91796f897807f2011eb203525902846d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:46:47 -0400 Subject: [PATCH 048/118] Rename toCategoryName to formatKind. --- src/Rendering/TOC.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 326cd7b64..3ed20d4d9 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -103,7 +103,7 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . | otherwise -> Map.insert key d { entry = Replaced, decl = similar } m _ -> Map.insert key d m - dedupeKey (Declaration kind ident _ _ _) = DedupeKey (toCategoryName kind) (T.toLower ident) + dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) -- | Construct a description of an 'Entry'. entryChange :: Entry -> Text @@ -117,7 +117,7 @@ entryChange entry = case entry of recordSummary :: Entry -> Declaration -> TOCSummary recordSummary entry decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language - | otherwise = TOCSummary (toCategoryName kind) (formatIdentifier decl) srcSpan (entryChange entry) + | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (entryChange entry) formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of @@ -135,9 +135,9 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration --- The user-facing category name -toCategoryName :: DeclarationKind -> T.Text -toCategoryName kind = case kind of +-- The user-facing kind +formatKind :: DeclarationKind -> T.Text +formatKind kind = case kind of FunctionDeclaration -> "Function" MethodDeclaration _ -> "Method" HeadingDeclaration l -> "Heading " <> T.pack (show l) From 429cf1e7c3e71488192a37a63c6c4f7891890288 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:47:02 -0400 Subject: [PATCH 049/118] Rename entryChange to formatEntry. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 3ed20d4d9..b82fcf25b 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -106,8 +106,8 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) -- | Construct a description of an 'Entry'. -entryChange :: Entry -> Text -entryChange entry = case entry of +formatEntry :: Entry -> Text +formatEntry entry = case entry of Changed -> "modified" Deleted -> "removed" Inserted -> "added" @@ -117,7 +117,7 @@ entryChange entry = case entry of recordSummary :: Entry -> Declaration -> TOCSummary recordSummary entry decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language - | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (entryChange entry) + | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatEntry entry) formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of From 27ad92b6b1a65b75612572dcd537dfd547ce554b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:54:57 -0400 Subject: [PATCH 050/118] Inline the definition of renderToCDiff into legacySummarizeDiff. --- src/Semantic/Api/Diffs.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index d7602ca86..765c3a2a8 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -22,11 +22,14 @@ import Control.Effect.Reader import Control.Exception import Control.Lens import Control.Monad.IO.Class +import Data.Aeson (toJSON) import Data.Blob import Data.ByteString.Builder import Data.Graph import Data.JSON.Fields import Data.Language +import qualified Data.List as List +import qualified Data.Map.Monoidal as Map import Data.ProtoLens (defMessage) import Data.Term import qualified Data.Text as T @@ -160,7 +163,10 @@ class DiffTerms term => LegacySummarizeDiff term where instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => LegacySummarizeDiff (Term syntax) where legacyDecorateTerm = decoratorWithAlgebra . declarationAlgebra - legacySummarizeDiff = renderToCDiff + legacySummarizeDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC where + toMap [] = mempty + toMap as = Map.singleton summaryKey (toJSON <$> as) + summaryKey = T.pack $ pathKeyForBlobPair blobs summarizeDiffParsers :: Map Language (SomeParser SummarizeDiff Loc) From cb77c1b8106475a44d0092a66d8e405fd979d034 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 18:55:32 -0400 Subject: [PATCH 051/118] :fire: renderToCDiff. --- src/Rendering/TOC.hs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index b82fcf25b..67ddf6ff8 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables, TupleSections #-} module Rendering.TOC -( renderToCDiff -, diffTOC +( diffTOC , Summaries(..) , TOCSummary(..) , isValidSummary @@ -15,11 +14,9 @@ import Prologue hiding (index) import Analysis.TOCSummary import Data.Align (bicrosswalk) import Data.Aeson -import Data.Blob import Data.Diff import Data.Language as Language import Data.List (sortOn) -import qualified Data.List as List import qualified Data.Map.Monoidal as Map import Data.Patch import Data.Term @@ -126,12 +123,6 @@ formatIdentifier (Declaration kind identifier _ _ lang) = case kind of | otherwise -> receiver <> "." <> identifier _ -> identifier -renderToCDiff :: (Foldable f, Functor f) => BlobPair -> Diff f (Maybe Declaration) (Maybe Declaration) -> Summaries -renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC - where toMap [] = mempty - toMap as = Map.singleton summaryKey (toJSON <$> as) - summaryKey = T.pack $ pathKeyForBlobPair blobs - diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration From def8e1b6fbe2bb0d8b4733e9505a1980c3f3f3f8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:11:36 -0400 Subject: [PATCH 052/118] Move the guts of summarizeDiff into TOCSummaries. --- src/Semantic/Api/Diffs.hs | 26 ++------------------------ src/Semantic/Api/TOCSummaries.hs | 22 +++++++++++++++++++++- 2 files changed, 23 insertions(+), 25 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 765c3a2a8..6545fdb84 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -174,33 +174,11 @@ summarizeDiffParsers = aLaCarteParsers class DiffTerms term => SummarizeDiff term where decorateTerm :: Blob -> term Loc -> term (Maybe Declaration) - summarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile + summarizeDiff :: DiffFor term (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where decorateTerm = decoratorWithAlgebra . declarationAlgebra - summarizeDiff blobPair diff = foldr go (defMessage & P.path .~ path & P.language .~ lang) (diffTOC diff) - where - path = T.pack $ pathKeyForBlobPair blobPair - lang = bridging # languageForBlobPair blobPair - - toChangeType = \case - "added" -> ADDED - "modified" -> MODIFIED - "removed" -> REMOVED - _ -> NONE - - go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile - go TOCSummary{..} file = defMessage - & P.path .~ file^.P.path - & P.language .~ file^.P.language - & P.changes .~ (defMessage & P.category .~ summaryCategoryName & P.term .~ summaryTermName & P.maybe'span .~ (converting #? summarySpan) & P.changeType .~ toChangeType summaryChangeType) : file^.P.changes - & P.errors .~ file^.P.errors - - go ErrorSummary{..} file = defMessage - & P.path .~ file^.P.path - & P.language .~ file^.P.language - & P.changes .~ file^.P.changes - & P.errors .~ (defMessage & P.error .~ errorText & P.maybe'span .~ converting #? errorSpan) : file^.P.errors + summarizeDiff = diffTOC -- | Parse a 'BlobPair' using one of the provided parsers, diff the resulting terms, and run an action on the abstracted diff. diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 5f71596ce..6a6487007 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where import Control.Effect.Error @@ -37,7 +38,7 @@ diffSummary blobs = do pure $ defMessage & P.files .~ diff where go :: DiffEffects sig m => BlobPair -> m TOCSummaryFile - go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff blobPair) blobPair + go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . foldr combine (defMessage & P.path .~ path & P.language .~ lang) . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ defMessage & P.path .~ path @@ -46,3 +47,22 @@ diffSummary blobs = do & P.errors .~ [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] where path = T.pack $ pathKeyForBlobPair blobPair lang = bridging # languageForBlobPair blobPair + + toChangeType = \case + "added" -> ADDED + "modified" -> MODIFIED + "removed" -> REMOVED + _ -> NONE + + combine :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile + combine TOCSummary{..} file = defMessage + & P.path .~ file^.P.path + & P.language .~ file^.P.language + & P.changes .~ (defMessage & P.category .~ summaryCategoryName & P.term .~ summaryTermName & P.maybe'span .~ (converting #? summarySpan) & P.changeType .~ toChangeType summaryChangeType) : file^.P.changes + & P.errors .~ file^.P.errors + + combine ErrorSummary{..} file = defMessage + & P.path .~ file^.P.path + & P.language .~ file^.P.language + & P.changes .~ file^.P.changes + & P.errors .~ (defMessage & P.error .~ errorText & P.maybe'span .~ converting #? errorSpan) : file^.P.errors From 7f959d1978b1a51d0806f0b79e235ac67e3683b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:13:14 -0400 Subject: [PATCH 053/118] Define legacyDiffSummary using summarizeDiff. --- src/Semantic/Api/TOCSummaries.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 6a6487007..dffa25b04 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -6,6 +6,7 @@ import Control.Lens import Data.Aeson import Data.Blob import Data.ByteString.Builder +import qualified Data.List as List import qualified Data.Map.Monoidal as Map import Data.ProtoLens (defMessage) import Data.Semilattice.Lower @@ -25,12 +26,16 @@ legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries legacyDiffSummary = distributeFoldMap go where go :: DiffEffects sig m => BlobPair -> m Summaries - go blobPair = decoratingDiffWith legacySummarizeDiffParsers legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair + go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)]) where path = T.pack $ pathKeyForBlobPair blobPair lang = languageForBlobPair blobPair + toMap [] = mempty + toMap as = Map.singleton summaryKey (toJSON <$> as) + summaryKey = T.pack $ pathKeyForBlobPair blobPair + diffSummary :: DiffEffects sig m => [BlobPair] -> m DiffTreeTOCResponse diffSummary blobs = do From dc6782c6b43c68671c0cf2f2f3c516e0a19e2123 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:13:59 -0400 Subject: [PATCH 054/118] :fire: LegacySummarizeDiff. --- src/Semantic/Api/Diffs.hs | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 6545fdb84..1fe5fcdfa 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -7,8 +7,6 @@ module Semantic.Api.Diffs , decoratingDiffWith , DiffEffects - , legacySummarizeDiffParsers - , LegacySummarizeDiff(..) , summarizeDiffParsers , SummarizeDiff(..) ) where @@ -22,14 +20,11 @@ import Control.Effect.Reader import Control.Exception import Control.Lens import Control.Monad.IO.Class -import Data.Aeson (toJSON) import Data.Blob import Data.ByteString.Builder import Data.Graph import Data.JSON.Fields import Data.Language -import qualified Data.List as List -import qualified Data.Map.Monoidal as Map import Data.ProtoLens (defMessage) import Data.Term import qualified Data.Text as T @@ -154,21 +149,6 @@ instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Show1 syntax, Traversab showDiff = serialize Show -legacySummarizeDiffParsers :: Map Language (SomeParser LegacySummarizeDiff Loc) -legacySummarizeDiffParsers = aLaCarteParsers - -class DiffTerms term => LegacySummarizeDiff term where - legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration) - legacySummarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> Summaries - -instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => LegacySummarizeDiff (Term syntax) where - legacyDecorateTerm = decoratorWithAlgebra . declarationAlgebra - legacySummarizeDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC where - toMap [] = mempty - toMap as = Map.singleton summaryKey (toJSON <$> as) - summaryKey = T.pack $ pathKeyForBlobPair blobs - - summarizeDiffParsers :: Map Language (SomeParser SummarizeDiff Loc) summarizeDiffParsers = aLaCarteParsers From fbf87d22c11752c27c6b0d442b650589b8a741e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:15:35 -0400 Subject: [PATCH 055/118] :fire: some redundant signatures. --- src/Semantic/Api/TOCSummaries.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index dffa25b04..36e832b62 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -25,7 +25,6 @@ diffSummaryBuilder format blobs = diffSummary blobs >>= serialize format legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries legacyDiffSummary = distributeFoldMap go where - go :: DiffEffects sig m => BlobPair -> m Summaries go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)]) @@ -42,7 +41,6 @@ diffSummary blobs = do diff <- distributeFor blobs go pure $ defMessage & P.files .~ diff where - go :: DiffEffects sig m => BlobPair -> m TOCSummaryFile go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . foldr combine (defMessage & P.path .~ path & P.language .~ lang) . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ defMessage From 58a208ddc863a427234e21325b71cf589c752ef3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:16:49 -0400 Subject: [PATCH 056/118] Align the TOCSummary fields. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 67ddf6ff8..792083a45 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -34,9 +34,9 @@ instance ToJSON Summaries where data TOCSummary = TOCSummary { summaryCategoryName :: T.Text - , summaryTermName :: T.Text - , summarySpan :: Span - , summaryChangeType :: T.Text + , summaryTermName :: T.Text + , summarySpan :: Span + , summaryChangeType :: T.Text } | ErrorSummary { errorText :: T.Text, errorSpan :: Span, errorLanguage :: Language } deriving stock (Generic, Eq, Show) From 3be5fa1953658aa48c1bfc9472c5d50a4614fde8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:18:27 -0400 Subject: [PATCH 057/118] :fire: the Generic instance for TOCSummary. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 792083a45..230195bc0 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -39,7 +39,7 @@ data TOCSummary , summaryChangeType :: T.Text } | ErrorSummary { errorText :: T.Text, errorSpan :: Span, errorLanguage :: Language } - deriving stock (Generic, Eq, Show) + deriving stock (Eq, Show) instance ToJSON TOCSummary where toJSON TOCSummary{..} = object [ "changeType" .= summaryChangeType, "category" .= summaryCategoryName, "term" .= summaryTermName, "span" .= summarySpan ] From 5d376b41a5e0cec1affe21368a9b86236e09e70e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:19:58 -0400 Subject: [PATCH 058/118] Rename the TOCSummary fields. --- src/Rendering/TOC.hs | 10 +++++----- src/Semantic/Api/TOCSummaries.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 230195bc0..fb15a0f66 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -33,16 +33,16 @@ instance ToJSON Summaries where data TOCSummary = TOCSummary - { summaryCategoryName :: T.Text - , summaryTermName :: T.Text - , summarySpan :: Span - , summaryChangeType :: T.Text + { kind :: T.Text + , ident :: T.Text + , span :: Span + , changeType :: T.Text } | ErrorSummary { errorText :: T.Text, errorSpan :: Span, errorLanguage :: Language } deriving stock (Eq, Show) instance ToJSON TOCSummary where - toJSON TOCSummary{..} = object [ "changeType" .= summaryChangeType, "category" .= summaryCategoryName, "term" .= summaryTermName, "span" .= summarySpan ] + toJSON TOCSummary{..} = object [ "changeType" .= changeType, "category" .= kind, "term" .= ident, "span" .= span ] toJSON ErrorSummary{..} = object [ "error" .= errorText, "span" .= errorSpan, "language" .= errorLanguage ] isValidSummary :: TOCSummary -> Bool diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 36e832b62..29aa16ebf 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -61,7 +61,7 @@ diffSummary blobs = do combine TOCSummary{..} file = defMessage & P.path .~ file^.P.path & P.language .~ file^.P.language - & P.changes .~ (defMessage & P.category .~ summaryCategoryName & P.term .~ summaryTermName & P.maybe'span .~ (converting #? summarySpan) & P.changeType .~ toChangeType summaryChangeType) : file^.P.changes + & P.changes .~ (defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType changeType) : file^.P.changes & P.errors .~ file^.P.errors combine ErrorSummary{..} file = defMessage From 9dc8140af7f98348f48d34270821ff9a80308b51 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:20:19 -0400 Subject: [PATCH 059/118] Reformat the ErrorSummary case. --- src/Rendering/TOC.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index fb15a0f66..54a3790e0 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -38,7 +38,11 @@ data TOCSummary , span :: Span , changeType :: T.Text } - | ErrorSummary { errorText :: T.Text, errorSpan :: Span, errorLanguage :: Language } + | ErrorSummary + { errorText :: T.Text + , errorSpan :: Span + , errorLanguage :: Language + } deriving stock (Eq, Show) instance ToJSON TOCSummary where From bd7c33d1ae6c2bae2de30e2ad8cc6a911918a23f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:20:25 -0400 Subject: [PATCH 060/118] Align. --- src/Rendering/TOC.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 54a3790e0..3e05a4cd2 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -39,8 +39,8 @@ data TOCSummary , changeType :: T.Text } | ErrorSummary - { errorText :: T.Text - , errorSpan :: Span + { errorText :: T.Text + , errorSpan :: Span , errorLanguage :: Language } deriving stock (Eq, Show) From bad94967a965ce5bc5130c350a7258587075f1fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:21:36 -0400 Subject: [PATCH 061/118] Rename the ErrorSummary fields. --- src/Rendering/TOC.hs | 8 ++++---- src/Semantic/Api/TOCSummaries.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 3e05a4cd2..4559f11c6 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -39,15 +39,15 @@ data TOCSummary , changeType :: T.Text } | ErrorSummary - { errorText :: T.Text - , errorSpan :: Span - , errorLanguage :: Language + { message :: T.Text + , span :: Span + , language :: Language } deriving stock (Eq, Show) instance ToJSON TOCSummary where toJSON TOCSummary{..} = object [ "changeType" .= changeType, "category" .= kind, "term" .= ident, "span" .= span ] - toJSON ErrorSummary{..} = object [ "error" .= errorText, "span" .= errorSpan, "language" .= errorLanguage ] + toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] isValidSummary :: TOCSummary -> Bool isValidSummary ErrorSummary{} = False diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 29aa16ebf..68e116a68 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -68,4 +68,4 @@ diffSummary blobs = do & P.path .~ file^.P.path & P.language .~ file^.P.language & P.changes .~ file^.P.changes - & P.errors .~ (defMessage & P.error .~ errorText & P.maybe'span .~ converting #? errorSpan) : file^.P.errors + & P.errors .~ (defMessage & P.error .~ message & P.maybe'span .~ converting #? span) : file^.P.errors From a1c9738d6906982f519765d218bcaec640e7e928 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:22:12 -0400 Subject: [PATCH 062/118] Move Entry up. --- src/Rendering/TOC.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 4559f11c6..0cf09cab3 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -49,15 +49,6 @@ instance ToJSON TOCSummary where toJSON TOCSummary{..} = object [ "changeType" .= changeType, "category" .= kind, "term" .= ident, "span" .= span ] toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] -isValidSummary :: TOCSummary -> Bool -isValidSummary ErrorSummary{} = False -isValidSummary _ = True - --- | Produce the annotations of nodes representing declarations. -declaration :: TermF f (Maybe Declaration) a -> Maybe Declaration -declaration (In annotation _) = annotation - - -- | An entry in a table of contents. data Entry = Changed -- ^ An entry for a node containing changes. @@ -67,6 +58,14 @@ data Entry deriving (Eq, Show) +isValidSummary :: TOCSummary -> Bool +isValidSummary ErrorSummary{} = False +isValidSummary _ = True + +-- | Produce the annotations of nodes representing declarations. +declaration :: TermF f (Maybe Declaration) a -> Maybe Declaration +declaration (In annotation _) = annotation + -- | Compute a table of contents for a diff characterized by a function mapping relevant nodes onto values in Maybe. tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. From dd4c6ed8a53e4f4f3d44de6870d3ba5e07cbb9cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:23:04 -0400 Subject: [PATCH 063/118] Rename Entry to ChangeType. --- src/Rendering/TOC.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 0cf09cab3..8015d6e7c 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -5,7 +5,7 @@ module Rendering.TOC , TOCSummary(..) , isValidSummary , declaration -, Entry(..) +, ChangeType(..) , tableOfContentsBy , dedupe ) where @@ -50,7 +50,7 @@ instance ToJSON TOCSummary where toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] -- | An entry in a table of contents. -data Entry +data ChangeType = Changed -- ^ An entry for a node containing changes. | Inserted -- ^ An entry for a change occurring inside an 'Insert' 'Patch'. | Deleted -- ^ An entry for a change occurring inside a 'Delete' 'Patch'. @@ -70,7 +70,7 @@ declaration (In annotation _) = annotation tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f ann ann -- ^ The diff to compute the table of contents for. - -> [(Entry, a)] -- ^ A list of entries for relevant changed nodes in the diff. + -> [(ChangeType, a)] -- ^ A list of entries for relevant changed nodes in the diff. tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just [] Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of @@ -84,7 +84,7 @@ data DedupeKey = DedupeKey {-# UNPACK #-} !T.Text {-# UNPACK #-} !T.Text data Dedupe = Dedupe { index :: {-# UNPACK #-} !Int - , entry :: {-# UNPACK #-} !Entry + , entry :: {-# UNPACK #-} !ChangeType , decl :: {-# UNPACK #-} !Declaration } @@ -95,7 +95,7 @@ data Dedupe = Dedupe -- 2. Two similar entries (defined by a case insensitive comparison of their -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. -dedupe :: [(Entry, Declaration)] -> [(Entry, Declaration)] +dedupe :: [(ChangeType, Declaration)] -> [(ChangeType, Declaration)] dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case Map.lookup key m of Just (Dedupe _ _ similar) @@ -105,8 +105,8 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) --- | Construct a description of an 'Entry'. -formatEntry :: Entry -> Text +-- | Construct a description of an 'ChangeType'. +formatEntry :: ChangeType -> Text formatEntry entry = case entry of Changed -> "modified" Deleted -> "removed" @@ -114,7 +114,7 @@ formatEntry entry = case entry of Replaced -> "modified" -- | Construct a 'TOCSummary' from a node annotation and a change type label. -recordSummary :: Entry -> Declaration -> TOCSummary +recordSummary :: ChangeType -> Declaration -> TOCSummary recordSummary entry decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatEntry entry) From 05e3944464a35714d1b39b47a8211b414b63d120 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:25:02 -0400 Subject: [PATCH 064/118] Rename the changeType field to change. --- src/Rendering/TOC.hs | 10 +++++----- src/Semantic/Api/TOCSummaries.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 8015d6e7c..8601c7110 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -33,10 +33,10 @@ instance ToJSON Summaries where data TOCSummary = TOCSummary - { kind :: T.Text - , ident :: T.Text - , span :: Span - , changeType :: T.Text + { kind :: T.Text + , ident :: T.Text + , span :: Span + , change :: T.Text } | ErrorSummary { message :: T.Text @@ -46,7 +46,7 @@ data TOCSummary deriving stock (Eq, Show) instance ToJSON TOCSummary where - toJSON TOCSummary{..} = object [ "changeType" .= changeType, "category" .= kind, "term" .= ident, "span" .= span ] + toJSON TOCSummary{..} = object [ "changeType" .= change, "category" .= kind, "term" .= ident, "span" .= span ] toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] -- | An entry in a table of contents. diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 68e116a68..37529959e 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -61,7 +61,7 @@ diffSummary blobs = do combine TOCSummary{..} file = defMessage & P.path .~ file^.P.path & P.language .~ file^.P.language - & P.changes .~ (defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType changeType) : file^.P.changes + & P.changes .~ (defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change) : file^.P.changes & P.errors .~ file^.P.errors combine ErrorSummary{..} file = defMessage From 27ae91c8837e507e99f7bdd8fc3ec5c0d8e49443 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:25:24 -0400 Subject: [PATCH 065/118] Rename ChangeType to Change. --- src/Rendering/TOC.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 8601c7110..96a665c2e 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -5,7 +5,7 @@ module Rendering.TOC , TOCSummary(..) , isValidSummary , declaration -, ChangeType(..) +, Change(..) , tableOfContentsBy , dedupe ) where @@ -50,7 +50,7 @@ instance ToJSON TOCSummary where toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] -- | An entry in a table of contents. -data ChangeType +data Change = Changed -- ^ An entry for a node containing changes. | Inserted -- ^ An entry for a change occurring inside an 'Insert' 'Patch'. | Deleted -- ^ An entry for a change occurring inside a 'Delete' 'Patch'. @@ -70,7 +70,7 @@ declaration (In annotation _) = annotation tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f ann ann -- ^ The diff to compute the table of contents for. - -> [(ChangeType, a)] -- ^ A list of entries for relevant changed nodes in the diff. + -> [(Change, a)] -- ^ A list of entries for relevant changed nodes in the diff. tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just [] Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of @@ -84,7 +84,7 @@ data DedupeKey = DedupeKey {-# UNPACK #-} !T.Text {-# UNPACK #-} !T.Text data Dedupe = Dedupe { index :: {-# UNPACK #-} !Int - , entry :: {-# UNPACK #-} !ChangeType + , entry :: {-# UNPACK #-} !Change , decl :: {-# UNPACK #-} !Declaration } @@ -95,7 +95,7 @@ data Dedupe = Dedupe -- 2. Two similar entries (defined by a case insensitive comparison of their -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. -dedupe :: [(ChangeType, Declaration)] -> [(ChangeType, Declaration)] +dedupe :: [(Change, Declaration)] -> [(Change, Declaration)] dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case Map.lookup key m of Just (Dedupe _ _ similar) @@ -105,8 +105,8 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) --- | Construct a description of an 'ChangeType'. -formatEntry :: ChangeType -> Text +-- | Construct a description of an 'Change'. +formatEntry :: Change -> Text formatEntry entry = case entry of Changed -> "modified" Deleted -> "removed" @@ -114,7 +114,7 @@ formatEntry entry = case entry of Replaced -> "modified" -- | Construct a 'TOCSummary' from a node annotation and a change type label. -recordSummary :: ChangeType -> Declaration -> TOCSummary +recordSummary :: Change -> Declaration -> TOCSummary recordSummary entry decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatEntry entry) From 8c0c6ebcd489348acc4290735e6274e32e976c35 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:26:55 -0400 Subject: [PATCH 066/118] Rename formatEntry to formatChange. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 96a665c2e..3e7b70dad 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -106,8 +106,8 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) -- | Construct a description of an 'Change'. -formatEntry :: Change -> Text -formatEntry entry = case entry of +formatChange :: Change -> Text +formatChange entry = case entry of Changed -> "modified" Deleted -> "removed" Inserted -> "added" @@ -117,7 +117,7 @@ formatEntry entry = case entry of recordSummary :: Change -> Declaration -> TOCSummary recordSummary entry decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language - | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatEntry entry) + | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatChange entry) formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of From 2d3f74f2b595660f84605b99ca28d4dc5a9dbd5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:27:26 -0400 Subject: [PATCH 067/118] Rename some variables. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 3e7b70dad..bff021c9f 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -107,7 +107,7 @@ dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . -- | Construct a description of an 'Change'. formatChange :: Change -> Text -formatChange entry = case entry of +formatChange change = case change of Changed -> "modified" Deleted -> "removed" Inserted -> "added" @@ -115,9 +115,9 @@ formatChange entry = case entry of -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: Change -> Declaration -> TOCSummary -recordSummary entry decl@(Declaration kind text _ srcSpan language) +recordSummary change decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language - | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatChange entry) + | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatChange change) formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of From 5b452bf4715f072788d435c3fe0f493466c4256f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:29:17 -0400 Subject: [PATCH 068/118] Rename the entry field of Dedupe to change. --- src/Rendering/TOC.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index bff021c9f..2a2686394 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE DerivingVia, DuplicateRecordFields, RankNTypes, ScopedTypeVariables, TupleSections #-} module Rendering.TOC ( diffTOC , Summaries(..) @@ -83,9 +83,9 @@ data DedupeKey = DedupeKey {-# UNPACK #-} !T.Text {-# UNPACK #-} !T.Text deriving (Eq, Ord) data Dedupe = Dedupe - { index :: {-# UNPACK #-} !Int - , entry :: {-# UNPACK #-} !Change - , decl :: {-# UNPACK #-} !Declaration + { index :: {-# UNPACK #-} !Int + , change :: {-# UNPACK #-} !Change + , decl :: {-# UNPACK #-} !Declaration } -- Dedupe entries in a final pass. This catches two specific scenarios with @@ -96,11 +96,11 @@ data Dedupe = Dedupe -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Change, Declaration)] -> [(Change, Declaration)] -dedupe = map (entry &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where +dedupe = map ((change :: Dedupe -> Change) &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case Map.lookup key m of Just (Dedupe _ _ similar) | similar == decl -> m - | otherwise -> Map.insert key d { entry = Replaced, decl = similar } m + | otherwise -> Map.insert key d { change = Replaced, decl = similar } m _ -> Map.insert key d m dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) From 7c6c677fda48c6f1faa04827dd208604182f1a9b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:34:24 -0400 Subject: [PATCH 069/118] Preserve the full Change in TOCSummary as late as possible. --- src/Rendering/TOC.hs | 19 +++++++++---------- src/Semantic/Api/TOCSummaries.hs | 8 ++++---- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 2a2686394..e9103b3c9 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -36,7 +36,7 @@ data TOCSummary { kind :: T.Text , ident :: T.Text , span :: Span - , change :: T.Text + , change :: Change } | ErrorSummary { message :: T.Text @@ -57,6 +57,13 @@ data Change | Replaced -- ^ An entry for a change occurring on the insertion side of a 'Replace' 'Patch'. deriving (Eq, Show) +instance ToJSON Change where + toJSON change = case change of + Changed -> "modified" + Deleted -> "removed" + Inserted -> "added" + Replaced -> "modified" + isValidSummary :: TOCSummary -> Bool isValidSummary ErrorSummary{} = False @@ -105,19 +112,11 @@ dedupe = map ((change :: Dedupe -> Change) &&& decl) . sortOn index . Map.elems dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) --- | Construct a description of an 'Change'. -formatChange :: Change -> Text -formatChange change = case change of - Changed -> "modified" - Deleted -> "removed" - Inserted -> "added" - Replaced -> "modified" - -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: Change -> Declaration -> TOCSummary recordSummary change decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = ErrorSummary text srcSpan language - | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan (formatChange change) + | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan change formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 37529959e..24b6ac2c5 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -52,10 +52,10 @@ diffSummary blobs = do lang = bridging # languageForBlobPair blobPair toChangeType = \case - "added" -> ADDED - "modified" -> MODIFIED - "removed" -> REMOVED - _ -> NONE + Changed -> MODIFIED + Deleted -> REMOVED + Inserted -> ADDED + Replaced -> MODIFIED combine :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile combine TOCSummary{..} file = defMessage From d531418ba211d22e69377cfcd9fb8981df19fd83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:35:50 -0400 Subject: [PATCH 070/118] Fix the docs for Change. --- src/Rendering/TOC.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index e9103b3c9..14d5117f9 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -49,12 +49,12 @@ instance ToJSON TOCSummary where toJSON TOCSummary{..} = object [ "changeType" .= change, "category" .= kind, "term" .= ident, "span" .= span ] toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] --- | An entry in a table of contents. +-- | The kind of a ToC change. data Change - = Changed -- ^ An entry for a node containing changes. - | Inserted -- ^ An entry for a change occurring inside an 'Insert' 'Patch'. - | Deleted -- ^ An entry for a change occurring inside a 'Delete' 'Patch'. - | Replaced -- ^ An entry for a change occurring on the insertion side of a 'Replace' 'Patch'. + = Changed + | Inserted + | Deleted + | Replaced deriving (Eq, Show) instance ToJSON Change where From 53b25956d28426d9ca0211decdfcdacf066f4cec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:36:15 -0400 Subject: [PATCH 071/118] Align. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 14d5117f9..13069931d 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -77,7 +77,7 @@ declaration (In annotation _) = annotation tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f ann ann -- ^ The diff to compute the table of contents for. - -> [(Change, a)] -- ^ A list of entries for relevant changed nodes in the diff. + -> [(Change, a)] -- ^ A list of entries for relevant changed nodes in the diff. tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just [] Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of From fd888e824303be8ce1df8af574463c522de4674c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:37:46 -0400 Subject: [PATCH 072/118] Derive an Ord instance for DeclarationKind. --- src/Analysis/TOCSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 33875fab6..9c91fe0ea 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -37,7 +37,7 @@ data DeclarationKind | FunctionDeclaration | HeadingDeclaration Int | ErrorDeclaration - deriving (Eq, Show) + deriving (Eq, Ord, Show) -- | An r-algebra producing 'Just' a 'Declaration' for syntax nodes corresponding to high-level declarations, or 'Nothing' otherwise. From c35d91736f2d72ed5f999e02b6ca529228d817ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:38:22 -0400 Subject: [PATCH 073/118] =?UTF-8?q?Don=E2=80=99t=20convert=20the=20kind=20?= =?UTF-8?q?to=20text=20during=20deduping.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rendering/TOC.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 13069931d..3f4032665 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -86,7 +86,7 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) -data DedupeKey = DedupeKey {-# UNPACK #-} !T.Text {-# UNPACK #-} !T.Text +data DedupeKey = DedupeKey !DeclarationKind {-# UNPACK #-} !T.Text deriving (Eq, Ord) data Dedupe = Dedupe @@ -110,7 +110,7 @@ dedupe = map ((change :: Dedupe -> Change) &&& decl) . sortOn index . Map.elems | otherwise -> Map.insert key d { change = Replaced, decl = similar } m _ -> Map.insert key d m - dedupeKey (Declaration kind ident _ _ _) = DedupeKey (formatKind kind) (T.toLower ident) + dedupeKey (Declaration kind ident _ _ _) = DedupeKey kind (T.toLower ident) -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: Change -> Declaration -> TOCSummary From 3ef5943117771246fe5953d4acf2d5ff181ad2c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:46:01 -0400 Subject: [PATCH 074/118] =?UTF-8?q?Don=E2=80=99t=20rebuild=20the=20whole?= =?UTF-8?q?=20message=20every=20step.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Semantic/Api/TOCSummaries.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 24b6ac2c5..1db7dd811 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -58,14 +58,8 @@ diffSummary blobs = do Replaced -> MODIFIED combine :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile - combine TOCSummary{..} file = defMessage - & P.path .~ file^.P.path - & P.language .~ file^.P.language + combine TOCSummary{..} file = file & P.changes .~ (defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change) : file^.P.changes - & P.errors .~ file^.P.errors - combine ErrorSummary{..} file = defMessage - & P.path .~ file^.P.path - & P.language .~ file^.P.language - & P.changes .~ file^.P.changes + combine ErrorSummary{..} file = file & P.errors .~ (defMessage & P.error .~ message & P.maybe'span .~ converting #? span) : file^.P.errors From 4417506758f290c1227539c15eafd93cf4e82f3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 22:55:47 -0400 Subject: [PATCH 075/118] Build lists in the fold. --- src/Semantic/Api/TOCSummaries.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 1db7dd811..278e8456d 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -41,7 +41,7 @@ diffSummary blobs = do diff <- distributeFor blobs go pure $ defMessage & P.files .~ diff where - go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . foldr combine (defMessage & P.path .~ path & P.language .~ lang) . summarizeDiff) blobPair + go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry toFile . foldr combine ([], []) . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ defMessage & P.path .~ path @@ -51,15 +51,19 @@ diffSummary blobs = do where path = T.pack $ pathKeyForBlobPair blobPair lang = bridging # languageForBlobPair blobPair + toFile changes errors = defMessage + & P.path .~ path + & P.language .~ lang + & P.changes .~ changes + & P.errors .~ errors + toChangeType = \case Changed -> MODIFIED Deleted -> REMOVED Inserted -> ADDED Replaced -> MODIFIED - combine :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile - combine TOCSummary{..} file = file - & P.changes .~ (defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change) : file^.P.changes + combine :: TOCSummary -> ([TOCSummaryChange], [TOCSummaryError]) -> ([TOCSummaryChange], [TOCSummaryError]) + combine TOCSummary{..} (changes, errors) = ((defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change) : changes, errors) - combine ErrorSummary{..} file = file - & P.errors .~ (defMessage & P.error .~ message & P.maybe'span .~ converting #? span) : file^.P.errors + combine ErrorSummary{..} (changes, errors) = (changes, (defMessage & P.error .~ message & P.maybe'span .~ converting #? span) : errors) From 9fc7b807e12da81e7751fdfed54a126eb8f22860 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:02:16 -0400 Subject: [PATCH 076/118] Split TOCSummary up into separate datatypes for valid and error summaries. --- src/Rendering/TOC.hs | 41 ++++++++++++++++---------------- src/Semantic/Api/Diffs.hs | 2 +- src/Semantic/Api/TOCSummaries.hs | 10 ++++---- 3 files changed, 26 insertions(+), 27 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 3f4032665..dd1d9cf7f 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -3,7 +3,7 @@ module Rendering.TOC ( diffTOC , Summaries(..) , TOCSummary(..) -, isValidSummary +, ErrorSummary(..) , declaration , Change(..) , tableOfContentsBy @@ -31,22 +31,25 @@ data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] } instance ToJSON Summaries where toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ] -data TOCSummary - = TOCSummary - { kind :: T.Text - , ident :: T.Text - , span :: Span - , change :: Change - } - | ErrorSummary - { message :: T.Text - , span :: Span - , language :: Language - } +data TOCSummary = TOCSummary + { kind :: T.Text + , ident :: T.Text + , span :: Span + , change :: Change + } + deriving stock (Eq, Show) + +data ErrorSummary = ErrorSummary + { message :: T.Text + , span :: Span + , language :: Language + } deriving stock (Eq, Show) instance ToJSON TOCSummary where toJSON TOCSummary{..} = object [ "changeType" .= change, "category" .= kind, "term" .= ident, "span" .= span ] + +instance ToJSON ErrorSummary where toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] -- | The kind of a ToC change. @@ -65,10 +68,6 @@ instance ToJSON Change where Replaced -> "modified" -isValidSummary :: TOCSummary -> Bool -isValidSummary ErrorSummary{} = False -isValidSummary _ = True - -- | Produce the annotations of nodes representing declarations. declaration :: TermF f (Maybe Declaration) a -> Maybe Declaration declaration (In annotation _) = annotation @@ -113,10 +112,10 @@ dedupe = map ((change :: Dedupe -> Change) &&& decl) . sortOn index . Map.elems dedupeKey (Declaration kind ident _ _ _) = DedupeKey kind (T.toLower ident) -- | Construct a 'TOCSummary' from a node annotation and a change type label. -recordSummary :: Change -> Declaration -> TOCSummary +recordSummary :: Change -> Declaration -> Either ErrorSummary TOCSummary recordSummary change decl@(Declaration kind text _ srcSpan language) - | ErrorDeclaration <- kind = ErrorSummary text srcSpan language - | otherwise = TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan change + | ErrorDeclaration <- kind = Left $ ErrorSummary text srcSpan language + | otherwise = Right $ TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan change formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of @@ -125,7 +124,7 @@ formatIdentifier (Declaration kind identifier _ _ lang) = case kind of | otherwise -> receiver <> "." <> identifier _ -> identifier -diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] +diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [Either ErrorSummary TOCSummary] diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration -- The user-facing kind diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 1fe5fcdfa..b29388a57 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -154,7 +154,7 @@ summarizeDiffParsers = aLaCarteParsers class DiffTerms term => SummarizeDiff term where decorateTerm :: Blob -> term Loc -> term (Maybe Declaration) - summarizeDiff :: DiffFor term (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] + summarizeDiff :: DiffFor term (Maybe Declaration) (Maybe Declaration) -> [Either ErrorSummary TOCSummary] instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where decorateTerm = decoratorWithAlgebra . declarationAlgebra diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 278e8456d..9ddcd47ef 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -6,7 +6,7 @@ import Control.Lens import Data.Aeson import Data.Blob import Data.ByteString.Builder -import qualified Data.List as List +import Data.Either (partitionEithers) import qualified Data.Map.Monoidal as Map import Data.ProtoLens (defMessage) import Data.Semilattice.Lower @@ -25,7 +25,7 @@ diffSummaryBuilder format blobs = diffSummary blobs >>= serialize format legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries legacyDiffSummary = distributeFoldMap go where - go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . summarizeDiff) blobPair + go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry Summaries . bimap toMap toMap . partitionEithers . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)]) where path = T.pack $ pathKeyForBlobPair blobPair @@ -63,7 +63,7 @@ diffSummary blobs = do Inserted -> ADDED Replaced -> MODIFIED - combine :: TOCSummary -> ([TOCSummaryChange], [TOCSummaryError]) -> ([TOCSummaryChange], [TOCSummaryError]) - combine TOCSummary{..} (changes, errors) = ((defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change) : changes, errors) + combine :: Either ErrorSummary TOCSummary -> ([TOCSummaryChange], [TOCSummaryError]) -> ([TOCSummaryChange], [TOCSummaryError]) + combine (Right TOCSummary{..}) (changes, errors) = ((defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change) : changes, errors) - combine ErrorSummary{..} (changes, errors) = (changes, (defMessage & P.error .~ message & P.maybe'span .~ converting #? span) : errors) + combine (Left ErrorSummary{..}) (changes, errors) = (changes, (defMessage & P.error .~ message & P.maybe'span .~ converting #? span) : errors) From e06187627f99740d17897d02cfaf093242084e64 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:08:36 -0400 Subject: [PATCH 077/118] Correct how we construct Summaries. --- src/Semantic/Api/TOCSummaries.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 9ddcd47ef..9164c56b5 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -25,7 +25,7 @@ diffSummaryBuilder format blobs = diffSummary blobs >>= serialize format legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries legacyDiffSummary = distributeFoldMap go where - go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry Summaries . bimap toMap toMap . partitionEithers . summarizeDiff) blobPair + go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry (flip Summaries) . bimap toMap toMap . partitionEithers . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)]) where path = T.pack $ pathKeyForBlobPair blobPair From 491d912c3eaced3261ca0a000794d9eb8881188b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:08:54 -0400 Subject: [PATCH 078/118] Map instead of folding. --- src/Semantic/Api/TOCSummaries.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 9164c56b5..144fc6d2b 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -41,7 +41,7 @@ diffSummary blobs = do diff <- distributeFor blobs go pure $ defMessage & P.files .~ diff where - go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry toFile . foldr combine ([], []) . summarizeDiff) blobPair + go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry toFile . partitionEithers . map (bimap toError toChange) . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ defMessage & P.path .~ path @@ -51,7 +51,7 @@ diffSummary blobs = do where path = T.pack $ pathKeyForBlobPair blobPair lang = bridging # languageForBlobPair blobPair - toFile changes errors = defMessage + toFile errors changes = defMessage & P.path .~ path & P.language .~ lang & P.changes .~ changes @@ -63,7 +63,8 @@ diffSummary blobs = do Inserted -> ADDED Replaced -> MODIFIED - combine :: Either ErrorSummary TOCSummary -> ([TOCSummaryChange], [TOCSummaryError]) -> ([TOCSummaryChange], [TOCSummaryError]) - combine (Right TOCSummary{..}) (changes, errors) = ((defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change) : changes, errors) + toChange :: TOCSummary -> TOCSummaryChange + toChange TOCSummary{..} = defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change - combine (Left ErrorSummary{..}) (changes, errors) = (changes, (defMessage & P.error .~ message & P.maybe'span .~ converting #? span) : errors) + toError :: ErrorSummary -> TOCSummaryError + toError ErrorSummary{..} = defMessage & P.error .~ message & P.maybe'span .~ converting #? span From 9ffddbd2033f104e9432ac4f97d93482ce97bb0b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:10:00 -0400 Subject: [PATCH 079/118] Reuse toFile. --- src/Semantic/Api/TOCSummaries.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 144fc6d2b..6a706e4bc 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -43,11 +43,7 @@ diffSummary blobs = do where go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry toFile . partitionEithers . map (bimap toError toChange) . summarizeDiff) blobPair `catchError` \(SomeException e) -> - pure $ defMessage - & P.path .~ path - & P.language .~ lang - & P.changes .~ mempty - & P.errors .~ [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] + pure $ toFile [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] [] where path = T.pack $ pathKeyForBlobPair blobPair lang = bridging # languageForBlobPair blobPair From a91fd4fd5a040be1b3b7c63a8634507e105af688 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:10:22 -0400 Subject: [PATCH 080/118] Align. --- src/Semantic/Api/TOCSummaries.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 6a706e4bc..ef8ec575f 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -48,10 +48,10 @@ diffSummary blobs = do lang = bridging # languageForBlobPair blobPair toFile errors changes = defMessage - & P.path .~ path + & P.path .~ path & P.language .~ lang - & P.changes .~ changes - & P.errors .~ errors + & P.changes .~ changes + & P.errors .~ errors toChangeType = \case Changed -> MODIFIED From 433288f715c9a3663639989737ad94afbd728cf2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:12:27 -0400 Subject: [PATCH 081/118] =?UTF-8?q?Don=E2=80=99t=20bind=20separate=20varia?= =?UTF-8?q?bles=20for=20path/lang.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Semantic/Api/TOCSummaries.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index ef8ec575f..368d76221 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -44,12 +44,9 @@ diffSummary blobs = do go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry toFile . partitionEithers . map (bimap toError toChange) . summarizeDiff) blobPair `catchError` \(SomeException e) -> pure $ toFile [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] [] - where path = T.pack $ pathKeyForBlobPair blobPair - lang = bridging # languageForBlobPair blobPair - - toFile errors changes = defMessage - & P.path .~ path - & P.language .~ lang + where toFile errors changes = defMessage + & P.path .~ T.pack (pathKeyForBlobPair blobPair) + & P.language .~ bridging # languageForBlobPair blobPair & P.changes .~ changes & P.errors .~ errors From 39a643c149fc2e73aea09ef1361a27793d1990f0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:13:06 -0400 Subject: [PATCH 082/118] :fire: summaryKey. --- src/Semantic/Api/TOCSummaries.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 368d76221..04d487c41 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -32,8 +32,7 @@ legacyDiffSummary = distributeFoldMap go lang = languageForBlobPair blobPair toMap [] = mempty - toMap as = Map.singleton summaryKey (toJSON <$> as) - summaryKey = T.pack $ pathKeyForBlobPair blobPair + toMap as = Map.singleton path (toJSON <$> as) diffSummary :: DiffEffects sig m => [BlobPair] -> m DiffTreeTOCResponse From 5e3fd0e6d13b19e9a6a090239b634cd4b1b98079 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Oct 2019 23:13:41 -0400 Subject: [PATCH 083/118] Reuse toMap. --- src/Semantic/Api/TOCSummaries.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 04d487c41..c15c63fe4 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -27,7 +27,7 @@ legacyDiffSummary = distributeFoldMap go where go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry (flip Summaries) . bimap toMap toMap . partitionEithers . summarizeDiff) blobPair `catchError` \(SomeException e) -> - pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)]) + pure $ Summaries mempty (toMap [ErrorSummary (T.pack (show e)) lowerBound lang]) where path = T.pack $ pathKeyForBlobPair blobPair lang = languageForBlobPair blobPair From 9c5a5be7f4551ec148134e63370a2466b1c9d863 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 02:44:18 -0400 Subject: [PATCH 084/118] Move formatKind into Analysis.TOCSummary. --- src/Analysis/TOCSummary.hs | 8 ++++++++ src/Rendering/TOC.hs | 8 -------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 9c91fe0ea..f80c6fecb 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -2,6 +2,7 @@ module Analysis.TOCSummary ( Declaration(..) , DeclarationKind(..) +, formatKind , HasDeclaration , declarationAlgebra ) where @@ -39,6 +40,13 @@ data DeclarationKind | ErrorDeclaration deriving (Eq, Ord, Show) +formatKind :: DeclarationKind -> T.Text +formatKind kind = case kind of + FunctionDeclaration -> "Function" + MethodDeclaration _ -> "Method" + HeadingDeclaration l -> "Heading " <> T.pack (show l) + ErrorDeclaration -> "ParseError" + -- | An r-algebra producing 'Just' a 'Declaration' for syntax nodes corresponding to high-level declarations, or 'Nothing' otherwise. -- diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index dd1d9cf7f..9e4a781a8 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -126,11 +126,3 @@ formatIdentifier (Declaration kind identifier _ _ lang) = case kind of diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [Either ErrorSummary TOCSummary] diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration - --- The user-facing kind -formatKind :: DeclarationKind -> T.Text -formatKind kind = case kind of - FunctionDeclaration -> "Function" - MethodDeclaration _ -> "Method" - HeadingDeclaration l -> "Heading " <> T.pack (show l) - ErrorDeclaration -> "ParseError" From 1990de19c21877824af9aad0136e4c3a2788da9b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 02:44:57 -0400 Subject: [PATCH 085/118] Fix an indentation bug. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 9e4a781a8..70014ae78 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -82,7 +82,7 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of (Just a, Just entries) -> Just ((Changed, a) : entries) (_ , entries) -> entries) - where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) + where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) data DedupeKey = DedupeKey !DeclarationKind {-# UNPACK #-} !T.Text From ea20b4e980734b39af5d0ab18062274fa4fc137f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 02:46:57 -0400 Subject: [PATCH 086/118] Preserve the kind in TOCSummary as late as possible. --- src/Rendering/TOC.hs | 6 +++--- src/Semantic/Api/TOCSummaries.hs | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 70014ae78..4edd91ad1 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -32,7 +32,7 @@ instance ToJSON Summaries where toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ] data TOCSummary = TOCSummary - { kind :: T.Text + { kind :: DeclarationKind , ident :: T.Text , span :: Span , change :: Change @@ -47,7 +47,7 @@ data ErrorSummary = ErrorSummary deriving stock (Eq, Show) instance ToJSON TOCSummary where - toJSON TOCSummary{..} = object [ "changeType" .= change, "category" .= kind, "term" .= ident, "span" .= span ] + toJSON TOCSummary{..} = object [ "changeType" .= change, "category" .= formatKind kind, "term" .= ident, "span" .= span ] instance ToJSON ErrorSummary where toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ] @@ -115,7 +115,7 @@ dedupe = map ((change :: Dedupe -> Change) &&& decl) . sortOn index . Map.elems recordSummary :: Change -> Declaration -> Either ErrorSummary TOCSummary recordSummary change decl@(Declaration kind text _ srcSpan language) | ErrorDeclaration <- kind = Left $ ErrorSummary text srcSpan language - | otherwise = Right $ TOCSummary (formatKind kind) (formatIdentifier decl) srcSpan change + | otherwise = Right $ TOCSummary kind (formatIdentifier decl) srcSpan change formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index c15c63fe4..05a7ad66e 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where +import Analysis.TOCSummary (formatKind) import Control.Effect.Error import Control.Lens import Data.Aeson @@ -56,7 +57,7 @@ diffSummary blobs = do Replaced -> MODIFIED toChange :: TOCSummary -> TOCSummaryChange - toChange TOCSummary{..} = defMessage & P.category .~ kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change + toChange TOCSummary{..} = defMessage & P.category .~ formatKind kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change toError :: ErrorSummary -> TOCSummaryError toError ErrorSummary{..} = defMessage & P.error .~ message & P.maybe'span .~ converting #? span From eb2ee42c7e3520736169be0cd199f8a1c4b66d65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 02:49:30 -0400 Subject: [PATCH 087/118] Extract some helpers to the top level. --- src/Semantic/Api/TOCSummaries.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 05a7ad66e..1380b780c 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -50,14 +50,15 @@ diffSummary blobs = do & P.changes .~ changes & P.errors .~ errors - toChangeType = \case - Changed -> MODIFIED - Deleted -> REMOVED - Inserted -> ADDED - Replaced -> MODIFIED +toChangeType :: Change -> ChangeType +toChangeType = \case + Changed -> MODIFIED + Deleted -> REMOVED + Inserted -> ADDED + Replaced -> MODIFIED - toChange :: TOCSummary -> TOCSummaryChange - toChange TOCSummary{..} = defMessage & P.category .~ formatKind kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change +toChange :: TOCSummary -> TOCSummaryChange +toChange TOCSummary{..} = defMessage & P.category .~ formatKind kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change - toError :: ErrorSummary -> TOCSummaryError - toError ErrorSummary{..} = defMessage & P.error .~ message & P.maybe'span .~ converting #? span +toError :: ErrorSummary -> TOCSummaryError +toError ErrorSummary{..} = defMessage & P.error .~ message & P.maybe'span .~ converting #? span From d23e0a17bac3bd6875eb425d5d492f4ccdc8a087 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 02:50:13 -0400 Subject: [PATCH 088/118] Reformat toChange/toError. --- src/Semantic/Api/TOCSummaries.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 1380b780c..da2f4d5c8 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -58,7 +58,13 @@ toChangeType = \case Replaced -> MODIFIED toChange :: TOCSummary -> TOCSummaryChange -toChange TOCSummary{..} = defMessage & P.category .~ formatKind kind & P.term .~ ident & P.maybe'span .~ (converting #? span) & P.changeType .~ toChangeType change +toChange TOCSummary{..} = defMessage + & P.category .~ formatKind kind + & P.term .~ ident + & P.maybe'span .~ (converting #? span) + & P.changeType .~ toChangeType change toError :: ErrorSummary -> TOCSummaryError -toError ErrorSummary{..} = defMessage & P.error .~ message & P.maybe'span .~ converting #? span +toError ErrorSummary{..} = defMessage + & P.error .~ message + & P.maybe'span .~ converting #? span From 12df95e5090cc0acf3d6f17621e99bcd98d0d39e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 02:56:10 -0400 Subject: [PATCH 089/118] Qualify the import of Data.Error. --- src/Analysis/TOCSummary.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index f80c6fecb..1b1ce4e22 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -12,7 +12,7 @@ import Prologue hiding (project) import Control.Arrow import Control.Rewriting import Data.Blob -import Data.Error (Error (..), Colourize (..), showExpectation) +import qualified Data.Error as Error import Data.Flag import Data.Language as Language import Source.Source as Source @@ -104,7 +104,7 @@ instance CustomHasDeclaration whole Markdown.Heading where instance CustomHasDeclaration whole Syntax.Error where customToDeclaration blob@Blob{..} ann err@Syntax.Error{} = Just $ Declaration ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) - where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) "" + where formatTOCError e = Error.showExpectation (flag Error.Colourize False) (Error.errorExpected e) (Error.errorActual e) "" -- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). instance CustomHasDeclaration whole Declaration.Function where From 3ddb57fb4c6f804e303bc8573801bc83bd582f7f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:04:41 -0400 Subject: [PATCH 090/118] List the Data.Aeson imports explicitly. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 4edd91ad1..66200fda8 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -13,7 +13,7 @@ module Rendering.TOC import Prologue hiding (index) import Analysis.TOCSummary import Data.Align (bicrosswalk) -import Data.Aeson +import Data.Aeson (ToJSON(..), Value, (.=), object) import Data.Diff import Data.Language as Language import Data.List (sortOn) From 62617b3eea9dd8b518e9b3374b889d3a97e11259 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:04:57 -0400 Subject: [PATCH 091/118] Rename the DeclarationKind constructors. --- src/Analysis/TOCSummary.hs | 36 ++++++++++++++++++------------------ src/Rendering/TOC.hs | 6 +++--- 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 1b1ce4e22..91ee2e12b 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -34,18 +34,18 @@ data Declaration = Declaration deriving (Eq, Show) data DeclarationKind - = MethodDeclaration (Maybe Text) - | FunctionDeclaration - | HeadingDeclaration Int - | ErrorDeclaration + = Method (Maybe Text) + | Function + | Heading Int + | Error deriving (Eq, Ord, Show) formatKind :: DeclarationKind -> T.Text formatKind kind = case kind of - FunctionDeclaration -> "Function" - MethodDeclaration _ -> "Method" - HeadingDeclaration l -> "Heading " <> T.pack (show l) - ErrorDeclaration -> "ParseError" + Function -> "Function" + Method _ -> "Method" + Heading l -> "Heading " <> T.pack (show l) + Error -> "ParseError" -- | An r-algebra producing 'Just' a 'Declaration' for syntax nodes corresponding to high-level declarations, or 'Nothing' otherwise. @@ -91,41 +91,41 @@ class CustomHasDeclaration whole syntax where customToDeclaration :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration --- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node. +-- | Produce a 'Heading' from the first line of the heading of a 'Markdown.Heading' node. instance CustomHasDeclaration whole Markdown.Heading where customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _) - = Just $ Declaration (HeadingDeclaration level) (headingText terms) mempty (Loc.span ann) (blobLanguage blob) + = Just $ Declaration (Heading level) (headingText terms) mempty (Loc.span ann) (blobLanguage blob) where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms)) headingByteRange (Term (In ann _), _) = byteRange ann getSource = firstLine . toText . Source.slice blobSource firstLine = T.takeWhile (/= '\n') --- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes. +-- | Produce an 'Error' for 'Syntax.Error' nodes. instance CustomHasDeclaration whole Syntax.Error where customToDeclaration blob@Blob{..} ann err@Syntax.Error{} - = Just $ Declaration ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) + = Just $ Declaration Error (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) where formatTOCError e = Error.showExpectation (flag Error.Colourize False) (Error.errorExpected e) (Error.errorActual e) "" --- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). +-- | Produce a 'Function' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). instance CustomHasDeclaration whole Declaration.Function where customToDeclaration blob@Blob{..} ann decl@(Declaration.Function _ (Term (In identifierAnn _), _) _ _) -- Do not summarize anonymous functions | isEmpty identifierAnn = Nothing -- Named functions - | otherwise = Just $ Declaration FunctionDeclaration (getSource blobSource identifierAnn) functionSource (Loc.span ann) (blobLanguage blob) + | otherwise = Just $ Declaration Function (getSource blobSource identifierAnn) functionSource (Loc.span ann) (blobLanguage blob) where isEmpty = (== 0) . rangeLength . byteRange functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl) --- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. +-- | Produce a 'Method' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. instance CustomHasDeclaration whole Declaration.Method where customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) -- Methods without a receiver - | isEmpty receiverAnn = Just $ Declaration (MethodDeclaration Nothing) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) + | isEmpty receiverAnn = Just $ Declaration (Method Nothing) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go). | blobLanguage blob == Go - , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ Declaration (MethodDeclaration (Just (getSource blobSource receiverType))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) + , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ Declaration (Method (Just (getSource blobSource receiverType))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) -- Methods with a receiver (class methods) are formatted like `receiver.method_name` - | otherwise = Just $ Declaration (MethodDeclaration (Just (getSource blobSource receiverAnn))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) + | otherwise = Just $ Declaration (Method (Just (getSource blobSource receiverAnn))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) where isEmpty = (== 0) . rangeLength . byteRange methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 66200fda8..967b0f923 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -114,12 +114,12 @@ dedupe = map ((change :: Dedupe -> Change) &&& decl) . sortOn index . Map.elems -- | Construct a 'TOCSummary' from a node annotation and a change type label. recordSummary :: Change -> Declaration -> Either ErrorSummary TOCSummary recordSummary change decl@(Declaration kind text _ srcSpan language) - | ErrorDeclaration <- kind = Left $ ErrorSummary text srcSpan language - | otherwise = Right $ TOCSummary kind (formatIdentifier decl) srcSpan change + | Error <- kind = Left $ ErrorSummary text srcSpan language + | otherwise = Right $ TOCSummary kind (formatIdentifier decl) srcSpan change formatIdentifier :: Declaration -> Text formatIdentifier (Declaration kind identifier _ _ lang) = case kind of - MethodDeclaration (Just receiver) + Method (Just receiver) | Language.Go <- lang -> "(" <> receiver <> ") " <> identifier | otherwise -> receiver <> "." <> identifier _ -> identifier From bed762db8efe17937c227e1e30dbbb9280411cc6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:05:33 -0400 Subject: [PATCH 092/118] Rename DeclarationKind to Kind. --- src/Analysis/TOCSummary.hs | 8 ++++---- src/Rendering/TOC.hs | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 91ee2e12b..2287b5b07 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.TOCSummary ( Declaration(..) -, DeclarationKind(..) +, Kind(..) , formatKind , HasDeclaration , declarationAlgebra @@ -26,21 +26,21 @@ import qualified Language.Markdown.Syntax as Markdown -- | A declaration’s identifier and type. data Declaration = Declaration - { kind :: DeclarationKind + { kind :: Kind , identifier :: Text , text :: Text , span :: Span , language :: Language } deriving (Eq, Show) -data DeclarationKind +data Kind = Method (Maybe Text) | Function | Heading Int | Error deriving (Eq, Ord, Show) -formatKind :: DeclarationKind -> T.Text +formatKind :: Kind -> T.Text formatKind kind = case kind of Function -> "Function" Method _ -> "Method" diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 967b0f923..34666b2a2 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -32,7 +32,7 @@ instance ToJSON Summaries where toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ] data TOCSummary = TOCSummary - { kind :: DeclarationKind + { kind :: Kind , ident :: T.Text , span :: Span , change :: Change @@ -85,7 +85,7 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) -data DedupeKey = DedupeKey !DeclarationKind {-# UNPACK #-} !T.Text +data DedupeKey = DedupeKey !Kind {-# UNPACK #-} !T.Text deriving (Eq, Ord) data Dedupe = Dedupe From 89b8fb13976357dbe80d615095cd252ad765f5d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:08:09 -0400 Subject: [PATCH 093/118] =?UTF-8?q?Don=E2=80=99t=20export=20declaration.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rendering/TOC.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 34666b2a2..badad9e9b 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -4,7 +4,6 @@ module Rendering.TOC , Summaries(..) , TOCSummary(..) , ErrorSummary(..) -, declaration , Change(..) , tableOfContentsBy , dedupe From ec7b0755ae9d2694af79e87936d635b9b4cc1811 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:13:01 -0400 Subject: [PATCH 094/118] :fire: redundant parens. --- src/Analysis/TOCSummary.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 2287b5b07..849206611 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -64,9 +64,9 @@ declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax -- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass class HasDeclaration syntax where - toDeclaration :: (Foldable syntax) => Blob -> Loc -> syntax (Term syntax Loc, Maybe Declaration) -> Maybe Declaration + toDeclaration :: Foldable syntax => Blob -> Loc -> syntax (Term syntax Loc, Maybe Declaration) -> Maybe Declaration -instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where +instance HasDeclaration' syntax syntax => HasDeclaration syntax where toDeclaration = toDeclaration' -- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'Declaration's for a new type is done by defining an instance of 'CustomHasDeclaration' instead. @@ -74,7 +74,7 @@ instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. class HasDeclaration' whole syntax where -- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). - toDeclaration' :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + toDeclaration' :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration -- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition. -- @@ -88,7 +88,7 @@ instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy stra -- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions). class CustomHasDeclaration whole syntax where -- | Produce a customized 'Declaration' for a given syntax node. - customToDeclaration :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + customToDeclaration :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration -- | Produce a 'Heading' from the first line of the heading of a 'Markdown.Heading' node. @@ -161,7 +161,7 @@ data Strategy = Default | Custom -- -- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class. class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where - toDeclarationWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + toDeclarationWithStrategy :: Foldable whole => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration -- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy. From 65fb560524e21a58ce635784e1b7111733c5e85a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:15:54 -0400 Subject: [PATCH 095/118] :fire: the `whole` parameter. --- src/Analysis/TOCSummary.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 849206611..f21dbfb56 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -66,13 +66,13 @@ declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax class HasDeclaration syntax where toDeclaration :: Foldable syntax => Blob -> Loc -> syntax (Term syntax Loc, Maybe Declaration) -> Maybe Declaration -instance HasDeclaration' syntax syntax => HasDeclaration syntax where +instance HasDeclaration' syntax => HasDeclaration syntax where toDeclaration = toDeclaration' -- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'Declaration's for a new type is done by defining an instance of 'CustomHasDeclaration' instead. -- -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. -class HasDeclaration' whole syntax where +class HasDeclaration' syntax where -- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). toDeclaration' :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration @@ -81,18 +81,18 @@ class HasDeclaration' whole syntax where -- This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'DeclarationStrategy' type family. Thus producing a 'Declaration' for a node requires both defining a 'CustomHasDeclaration' instance _and_ adding a definition for the type to the 'DeclarationStrategy' type family to return 'Custom'. -- -- Note that since 'DeclarationStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasDeclaration', as any other instance would be indistinguishable. -instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy strategy whole syntax) => HasDeclaration' whole syntax where +instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy strategy syntax) => HasDeclaration' syntax where toDeclaration' = toDeclarationWithStrategy (Proxy :: Proxy strategy) -- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions). -class CustomHasDeclaration whole syntax where +class CustomHasDeclaration syntax where -- | Produce a customized 'Declaration' for a given syntax node. customToDeclaration :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration -- | Produce a 'Heading' from the first line of the heading of a 'Markdown.Heading' node. -instance CustomHasDeclaration whole Markdown.Heading where +instance CustomHasDeclaration Markdown.Heading where customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _) = Just $ Declaration (Heading level) (headingText terms) mempty (Loc.span ann) (blobLanguage blob) where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms)) @@ -101,13 +101,13 @@ instance CustomHasDeclaration whole Markdown.Heading where firstLine = T.takeWhile (/= '\n') -- | Produce an 'Error' for 'Syntax.Error' nodes. -instance CustomHasDeclaration whole Syntax.Error where +instance CustomHasDeclaration Syntax.Error where customToDeclaration blob@Blob{..} ann err@Syntax.Error{} = Just $ Declaration Error (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) where formatTOCError e = Error.showExpectation (flag Error.Colourize False) (Error.errorExpected e) (Error.errorActual e) "" -- | Produce a 'Function' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). -instance CustomHasDeclaration whole Declaration.Function where +instance CustomHasDeclaration Declaration.Function where customToDeclaration blob@Blob{..} ann decl@(Declaration.Function _ (Term (In identifierAnn _), _) _ _) -- Do not summarize anonymous functions | isEmpty identifierAnn = Nothing @@ -117,7 +117,7 @@ instance CustomHasDeclaration whole Declaration.Function where functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl) -- | Produce a 'Method' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. -instance CustomHasDeclaration whole Declaration.Method where +instance CustomHasDeclaration Declaration.Method where customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) -- Methods without a receiver | isEmpty receiverAnn = Just $ Declaration (Method Nothing) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) @@ -150,8 +150,8 @@ getSource :: Source -> Loc -> Text getSource blobSource = toText . Source.slice blobSource . byteRange -- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'. -instance Apply (HasDeclaration' whole) fs => CustomHasDeclaration whole (Sum fs) where - customToDeclaration blob ann = apply @(HasDeclaration' whole) (toDeclaration' blob ann) +instance Apply HasDeclaration' fs => CustomHasDeclaration (Sum fs) where + customToDeclaration blob ann = apply @HasDeclaration' (toDeclaration' blob ann) -- | A strategy for defining a 'HasDeclaration' instance. Intended to be promoted to the kind level using @-XDataKinds@. @@ -160,7 +160,7 @@ data Strategy = Default | Custom -- | Produce a 'Declaration' for a syntax node using either the 'Default' or 'Custom' strategy. -- -- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class. -class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where +class HasDeclarationWithStrategy (strategy :: Strategy) syntax where toDeclarationWithStrategy :: Foldable whole => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration @@ -179,9 +179,9 @@ type family DeclarationStrategy syntax where -- | The 'Default' strategy produces 'Nothing'. -instance HasDeclarationWithStrategy 'Default whole syntax where +instance HasDeclarationWithStrategy 'Default syntax where toDeclarationWithStrategy _ _ _ _ = Nothing -- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasDeclaration' instance for the type. -instance CustomHasDeclaration whole syntax => HasDeclarationWithStrategy 'Custom whole syntax where +instance CustomHasDeclaration syntax => HasDeclarationWithStrategy 'Custom syntax where toDeclarationWithStrategy _ = customToDeclaration From 30a26f7ff2f1dda58cbd4527cce869be5dfd3757 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:17:04 -0400 Subject: [PATCH 096/118] :fire: HasDeclaration'. --- src/Analysis/TOCSummary.hs | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index f21dbfb56..22b262ac5 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -62,27 +62,20 @@ declarationAlgebra :: (Foldable syntax, HasDeclaration syntax) => Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe Declaration) declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax --- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass -class HasDeclaration syntax where - toDeclaration :: Foldable syntax => Blob -> Loc -> syntax (Term syntax Loc, Maybe Declaration) -> Maybe Declaration - -instance HasDeclaration' syntax => HasDeclaration syntax where - toDeclaration = toDeclaration' - -- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'Declaration's for a new type is done by defining an instance of 'CustomHasDeclaration' instead. -- -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. -class HasDeclaration' syntax where +class HasDeclaration syntax where -- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). - toDeclaration' :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + toDeclaration :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration -- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition. -- -- This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'DeclarationStrategy' type family. Thus producing a 'Declaration' for a node requires both defining a 'CustomHasDeclaration' instance _and_ adding a definition for the type to the 'DeclarationStrategy' type family to return 'Custom'. -- -- Note that since 'DeclarationStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasDeclaration', as any other instance would be indistinguishable. -instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy strategy syntax) => HasDeclaration' syntax where - toDeclaration' = toDeclarationWithStrategy (Proxy :: Proxy strategy) +instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy strategy syntax) => HasDeclaration syntax where + toDeclaration = toDeclarationWithStrategy (Proxy :: Proxy strategy) -- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions). @@ -150,8 +143,8 @@ getSource :: Source -> Loc -> Text getSource blobSource = toText . Source.slice blobSource . byteRange -- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'. -instance Apply HasDeclaration' fs => CustomHasDeclaration (Sum fs) where - customToDeclaration blob ann = apply @HasDeclaration' (toDeclaration' blob ann) +instance Apply HasDeclaration fs => CustomHasDeclaration (Sum fs) where + customToDeclaration blob ann = apply @HasDeclaration (toDeclaration blob ann) -- | A strategy for defining a 'HasDeclaration' instance. Intended to be promoted to the kind level using @-XDataKinds@. From 1f58e9a82dd7b35c1842fcddf27e6038d3117141 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:18:14 -0400 Subject: [PATCH 097/118] Rename HasDeclarationWithStrategy to HasDeclarationBy. --- src/Analysis/TOCSummary.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 22b262ac5..25695ff17 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -74,8 +74,8 @@ class HasDeclaration syntax where -- This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'DeclarationStrategy' type family. Thus producing a 'Declaration' for a node requires both defining a 'CustomHasDeclaration' instance _and_ adding a definition for the type to the 'DeclarationStrategy' type family to return 'Custom'. -- -- Note that since 'DeclarationStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasDeclaration', as any other instance would be indistinguishable. -instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy strategy syntax) => HasDeclaration syntax where - toDeclaration = toDeclarationWithStrategy (Proxy :: Proxy strategy) +instance (DeclarationStrategy syntax ~ strategy, HasDeclarationBy strategy syntax) => HasDeclaration syntax where + toDeclaration = toDeclarationBy (Proxy :: Proxy strategy) -- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions). @@ -153,8 +153,8 @@ data Strategy = Default | Custom -- | Produce a 'Declaration' for a syntax node using either the 'Default' or 'Custom' strategy. -- -- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class. -class HasDeclarationWithStrategy (strategy :: Strategy) syntax where - toDeclarationWithStrategy :: Foldable whole => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration +class HasDeclarationBy (strategy :: Strategy) syntax where + toDeclarationBy :: Foldable whole => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration -- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy. @@ -172,9 +172,9 @@ type family DeclarationStrategy syntax where -- | The 'Default' strategy produces 'Nothing'. -instance HasDeclarationWithStrategy 'Default syntax where - toDeclarationWithStrategy _ _ _ _ = Nothing +instance HasDeclarationBy 'Default syntax where + toDeclarationBy _ _ _ _ = Nothing -- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasDeclaration' instance for the type. -instance CustomHasDeclaration syntax => HasDeclarationWithStrategy 'Custom syntax where - toDeclarationWithStrategy _ = customToDeclaration +instance CustomHasDeclaration syntax => HasDeclarationBy 'Custom syntax where + toDeclarationBy _ = customToDeclaration From 698cc4392df89379b9cc7aaf6002a576daa47b84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:23:13 -0400 Subject: [PATCH 098/118] :fire: CustomHasDeclaration. --- src/Analysis/TOCSummary.hs | 63 +++++++++++++++----------------------- 1 file changed, 25 insertions(+), 38 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 25695ff17..3d27b8c97 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -52,41 +52,44 @@ formatKind kind = case kind of -- -- Customizing this for a given syntax type involves two steps: -- --- 1. Defining a 'CustomHasDeclaration' instance for the type. +-- 1. Defining a @'HasDeclarationBy' ''Custom'@ instance for the type. -- 2. Adding the type to the 'DeclarationStrategy' type family. -- --- If you’re getting errors about missing a 'CustomHasDeclaration' instance for your syntax type, you probably forgot step 1. +-- If you’re getting errors about missing a @'HasDeclarationBy' ''Custom'@ instance for your syntax type, you probably forgot step 1. -- -- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2. declarationAlgebra :: (Foldable syntax, HasDeclaration syntax) => Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe Declaration) declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax --- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'Declaration's for a new type is done by defining an instance of 'CustomHasDeclaration' instead. +-- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'Declaration's for a new type is done by defining an instance of @'HasDeclarationBy' ''Custom'@ instead. -- -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. class HasDeclaration syntax where - -- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). + -- | Compute a 'Declaration' for a syntax type using its @'HasDeclarationBy' ''Custom'@ instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). toDeclaration :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration --- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition. +-- | Define 'toDeclaration' using the @'HasDeclarationBy' ''Custom'@ instance for a type if there is one or else use the default definition. -- --- This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'DeclarationStrategy' type family. Thus producing a 'Declaration' for a node requires both defining a 'CustomHasDeclaration' instance _and_ adding a definition for the type to the 'DeclarationStrategy' type family to return 'Custom'. +-- This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'DeclarationStrategy' type family. Thus producing a 'Declaration' for a node requires both defining a @'HasDeclarationBy' ''Custom'@ instance _and_ adding a definition for the type to the 'DeclarationStrategy' type family to return 'Custom'. -- -- Note that since 'DeclarationStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasDeclaration', as any other instance would be indistinguishable. instance (DeclarationStrategy syntax ~ strategy, HasDeclarationBy strategy syntax) => HasDeclaration syntax where toDeclaration = toDeclarationBy (Proxy :: Proxy strategy) --- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions). -class CustomHasDeclaration syntax where - -- | Produce a customized 'Declaration' for a given syntax node. - customToDeclaration :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration +-- | Produce a 'Declaration' for a syntax node using either the 'Default' or 'Custom' strategy. +class HasDeclarationBy (strategy :: Strategy) syntax where + toDeclarationBy :: Foldable whole => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + +-- | The 'Default' strategy produces 'Nothing'. +instance HasDeclarationBy 'Default syntax where + toDeclarationBy _ _ _ _ = Nothing -- | Produce a 'Heading' from the first line of the heading of a 'Markdown.Heading' node. -instance CustomHasDeclaration Markdown.Heading where - customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _) +instance HasDeclarationBy 'Custom Markdown.Heading where + toDeclarationBy _ blob@Blob{..} ann (Markdown.Heading level terms _) = Just $ Declaration (Heading level) (headingText terms) mempty (Loc.span ann) (blobLanguage blob) where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms)) headingByteRange (Term (In ann _), _) = byteRange ann @@ -94,14 +97,14 @@ instance CustomHasDeclaration Markdown.Heading where firstLine = T.takeWhile (/= '\n') -- | Produce an 'Error' for 'Syntax.Error' nodes. -instance CustomHasDeclaration Syntax.Error where - customToDeclaration blob@Blob{..} ann err@Syntax.Error{} +instance HasDeclarationBy 'Custom Syntax.Error where + toDeclarationBy _ blob@Blob{..} ann err@Syntax.Error{} = Just $ Declaration Error (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) where formatTOCError e = Error.showExpectation (flag Error.Colourize False) (Error.errorExpected e) (Error.errorActual e) "" -- | Produce a 'Function' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). -instance CustomHasDeclaration Declaration.Function where - customToDeclaration blob@Blob{..} ann decl@(Declaration.Function _ (Term (In identifierAnn _), _) _ _) +instance HasDeclarationBy 'Custom Declaration.Function where + toDeclarationBy _ blob@Blob{..} ann decl@(Declaration.Function _ (Term (In identifierAnn _), _) _ _) -- Do not summarize anonymous functions | isEmpty identifierAnn = Nothing -- Named functions @@ -110,8 +113,8 @@ instance CustomHasDeclaration Declaration.Function where functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl) -- | Produce a 'Method' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. -instance CustomHasDeclaration Declaration.Method where - customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) +instance HasDeclarationBy 'Custom Declaration.Method where + toDeclarationBy _ blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) -- Methods without a receiver | isEmpty receiverAnn = Just $ Declaration (Method Nothing) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go). @@ -142,26 +145,19 @@ getIdentifier finder Blob{..} (In a r) getSource :: Source -> Loc -> Text getSource blobSource = toText . Source.slice blobSource . byteRange --- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'. -instance Apply HasDeclaration fs => CustomHasDeclaration (Sum fs) where - customToDeclaration blob ann = apply @HasDeclaration (toDeclaration blob ann) +-- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a @'HasDeclarationBy' ''Custom'@ instance when one exists & the type is listed in 'DeclarationStrategy'. +instance Apply HasDeclaration fs => HasDeclarationBy 'Custom (Sum fs) where + toDeclarationBy _ blob ann = apply @HasDeclaration (toDeclaration blob ann) -- | A strategy for defining a 'HasDeclaration' instance. Intended to be promoted to the kind level using @-XDataKinds@. data Strategy = Default | Custom --- | Produce a 'Declaration' for a syntax node using either the 'Default' or 'Custom' strategy. --- --- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class. -class HasDeclarationBy (strategy :: Strategy) syntax where - toDeclarationBy :: Foldable whole => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration - - -- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy. -- -- Only entries for which we want to use the 'Custom' strategy should be listed, with the exception of the final entry which maps all other types onto the 'Default' strategy. -- --- If you’re seeing errors about missing a 'CustomHasDeclaration' instance for a given type, you’ve probably listed it in here but not defined a 'CustomHasDeclaration' instance for it, or else you’ve listed the wrong type in here. Conversely, if your 'customHasDeclaration' method is never being called, you may have forgotten to list the type in here. +-- If you’re seeing errors about missing a @'HasDeclarationBy' ''Custom'@ instance for a given type, you’ve probably listed it in here but not defined a @'HasDeclarationBy' ''Custom'@ instance for it, or else you’ve listed the wrong type in here. Conversely, if your @'HasDeclarationBy' ''Custom'@ method is never being called, you may have forgotten to list the type in here. type family DeclarationStrategy syntax where DeclarationStrategy Declaration.Function = 'Custom DeclarationStrategy Declaration.Method = 'Custom @@ -169,12 +165,3 @@ type family DeclarationStrategy syntax where DeclarationStrategy Syntax.Error = 'Custom DeclarationStrategy (Sum fs) = 'Custom DeclarationStrategy a = 'Default - - --- | The 'Default' strategy produces 'Nothing'. -instance HasDeclarationBy 'Default syntax where - toDeclarationBy _ _ _ _ = Nothing - --- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasDeclaration' instance for the type. -instance CustomHasDeclaration syntax => HasDeclarationBy 'Custom syntax where - toDeclarationBy _ = customToDeclaration From 9b2ddd3cbe1fb15839a4232b8237fcb595439169 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:24:09 -0400 Subject: [PATCH 099/118] Sort imports. --- src/Analysis/TOCSummary.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 3d27b8c97..832ee6439 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -15,14 +15,14 @@ import Data.Blob import qualified Data.Error as Error import Data.Flag import Data.Language as Language -import Source.Source as Source import qualified Data.Syntax as Syntax import qualified Data.Syntax.Declaration as Declaration import Data.Term import qualified Data.Text as T +import qualified Language.Markdown.Syntax as Markdown import Source.Loc as Loc import Source.Range -import qualified Language.Markdown.Syntax as Markdown +import Source.Source as Source -- | A declaration’s identifier and type. data Declaration = Declaration From 5611398aa7230396d781e48206040ff1a2ae0d56 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:24:45 -0400 Subject: [PATCH 100/118] Align. --- src/Analysis/TOCSummary.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 832ee6439..961c63c26 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -160,8 +160,8 @@ data Strategy = Default | Custom -- If you’re seeing errors about missing a @'HasDeclarationBy' ''Custom'@ instance for a given type, you’ve probably listed it in here but not defined a @'HasDeclarationBy' ''Custom'@ instance for it, or else you’ve listed the wrong type in here. Conversely, if your @'HasDeclarationBy' ''Custom'@ method is never being called, you may have forgotten to list the type in here. type family DeclarationStrategy syntax where DeclarationStrategy Declaration.Function = 'Custom - DeclarationStrategy Declaration.Method = 'Custom - DeclarationStrategy Markdown.Heading = 'Custom - DeclarationStrategy Syntax.Error = 'Custom - DeclarationStrategy (Sum fs) = 'Custom - DeclarationStrategy a = 'Default + DeclarationStrategy Declaration.Method = 'Custom + DeclarationStrategy Markdown.Heading = 'Custom + DeclarationStrategy Syntax.Error = 'Custom + DeclarationStrategy (Sum fs) = 'Custom + DeclarationStrategy a = 'Default From baf1868d4835f39ddfafddfa61b66a44fcaec358 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:25:51 -0400 Subject: [PATCH 101/118] :fire: the proxies. --- src/Analysis/TOCSummary.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 961c63c26..0e529a365 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.TOCSummary ( Declaration(..) , Kind(..) @@ -75,21 +75,21 @@ class HasDeclaration syntax where -- -- Note that since 'DeclarationStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasDeclaration', as any other instance would be indistinguishable. instance (DeclarationStrategy syntax ~ strategy, HasDeclarationBy strategy syntax) => HasDeclaration syntax where - toDeclaration = toDeclarationBy (Proxy :: Proxy strategy) + toDeclaration = toDeclarationBy @strategy -- | Produce a 'Declaration' for a syntax node using either the 'Default' or 'Custom' strategy. class HasDeclarationBy (strategy :: Strategy) syntax where - toDeclarationBy :: Foldable whole => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + toDeclarationBy :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration -- | The 'Default' strategy produces 'Nothing'. instance HasDeclarationBy 'Default syntax where - toDeclarationBy _ _ _ _ = Nothing + toDeclarationBy _ _ _ = Nothing -- | Produce a 'Heading' from the first line of the heading of a 'Markdown.Heading' node. instance HasDeclarationBy 'Custom Markdown.Heading where - toDeclarationBy _ blob@Blob{..} ann (Markdown.Heading level terms _) + toDeclarationBy blob@Blob{..} ann (Markdown.Heading level terms _) = Just $ Declaration (Heading level) (headingText terms) mempty (Loc.span ann) (blobLanguage blob) where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms)) headingByteRange (Term (In ann _), _) = byteRange ann @@ -98,13 +98,13 @@ instance HasDeclarationBy 'Custom Markdown.Heading where -- | Produce an 'Error' for 'Syntax.Error' nodes. instance HasDeclarationBy 'Custom Syntax.Error where - toDeclarationBy _ blob@Blob{..} ann err@Syntax.Error{} + toDeclarationBy blob@Blob{..} ann err@Syntax.Error{} = Just $ Declaration Error (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob) where formatTOCError e = Error.showExpectation (flag Error.Colourize False) (Error.errorExpected e) (Error.errorActual e) "" -- | Produce a 'Function' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). instance HasDeclarationBy 'Custom Declaration.Function where - toDeclarationBy _ blob@Blob{..} ann decl@(Declaration.Function _ (Term (In identifierAnn _), _) _ _) + toDeclarationBy blob@Blob{..} ann decl@(Declaration.Function _ (Term (In identifierAnn _), _) _ _) -- Do not summarize anonymous functions | isEmpty identifierAnn = Nothing -- Named functions @@ -114,7 +114,7 @@ instance HasDeclarationBy 'Custom Declaration.Function where -- | Produce a 'Method' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. instance HasDeclarationBy 'Custom Declaration.Method where - toDeclarationBy _ blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) + toDeclarationBy blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) -- Methods without a receiver | isEmpty receiverAnn = Just $ Declaration (Method Nothing) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go). @@ -147,7 +147,7 @@ getSource blobSource = toText . Source.slice blobSource . byteRange -- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a @'HasDeclarationBy' ''Custom'@ instance when one exists & the type is listed in 'DeclarationStrategy'. instance Apply HasDeclaration fs => HasDeclarationBy 'Custom (Sum fs) where - toDeclarationBy _ blob ann = apply @HasDeclaration (toDeclaration blob ann) + toDeclarationBy blob ann = apply @HasDeclaration (toDeclaration blob ann) -- | A strategy for defining a 'HasDeclaration' instance. Intended to be promoted to the kind level using @-XDataKinds@. From 98be55d0e4cbdeeb329ec739996812a88ee39d84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:30:53 -0400 Subject: [PATCH 102/118] :fire: an obsolete test. --- test/Rendering/TOC/Spec.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 9337e7ba4..55ab577d5 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -65,15 +65,6 @@ spec = do , TOCSummary "Method" "baz" (Span (Pos 4 1) (Pos 5 4)) "removed" ] - xit "summarizes changed classes" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/classes.A.rb") (Path.relFile "ruby/toc/classes.B.rb")) - diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs - diffTOC diff `shouldBe` - [ TOCSummary "Class" "Baz" (Span (Pos 1 1) (Pos 2 4)) "removed" - , TOCSummary "Class" "Foo" (Span (Pos 1 1) (Pos 3 4)) "modified" - , TOCSummary "Class" "Bar" (Span (Pos 5 1) (Pos 6 4)) "added" - ] - it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")) diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs From b682d04653bbf2d852af3d6fc25092b0ab829c63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:39:28 -0400 Subject: [PATCH 103/118] :fire: a redundant UNPACK pragma. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index badad9e9b..0fd9850ca 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -89,7 +89,7 @@ data DedupeKey = DedupeKey !Kind {-# UNPACK #-} !T.Text data Dedupe = Dedupe { index :: {-# UNPACK #-} !Int - , change :: {-# UNPACK #-} !Change + , change :: !Change , decl :: {-# UNPACK #-} !Declaration } From e340b4350038a2e2324c2ec3f18fc90b9ed46f07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:45:29 -0400 Subject: [PATCH 104/118] Fix the Listable instances for ToC. --- test/Data/Functor/Listable.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 2a9d2f90e..286aa679e 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -16,7 +16,7 @@ module Data.Functor.Listable , ListableSyntax ) where -import Analysis.TOCSummary +import qualified Analysis.TOCSummary as ToC import Data.Abstract.ScopeGraph (AccessControl(..)) import Data.Bifunctor.Join import Data.Diff @@ -215,11 +215,14 @@ instance Listable Name.Name where instance Listable Text where tiers = pack `mapT` tiers -instance Listable Declaration where +instance Listable ToC.Declaration where + tiers = cons5 ToC.Declaration + +instance Listable ToC.Kind where tiers - = cons5 MethodDeclaration - \/ cons4 FunctionDeclaration - \/ cons3 (\ a b c -> ErrorDeclaration a b c Language.Unknown) + = cons1 ToC.Method + \/ cons0 ToC.Function + \/ cons0 ToC.Error instance Listable Language.Language where tiers From 5d66493f56a86d770073992229328b1fe855b71e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:48:05 -0400 Subject: [PATCH 105/118] Get the ToC spec compiling again. --- test/Rendering/TOC/Spec.hs | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 55ab577d5..3d2861afe 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-} +{-# LANGUAGE DataKinds, MonoLocalBinds, TupleSections, TypeOperators #-} module Rendering.TOC.Spec (spec) where import Analysis.Decorator @@ -9,6 +9,7 @@ import Data.Aeson hiding (defaultOptions) import Data.Bifunctor import Data.Bifunctor.Join import Data.Diff +import Data.Either (isRight) import Data.Functor.Classes import Data.Hashable.Lifted import Data.Patch @@ -43,14 +44,14 @@ spec = do prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $ \ p -> tableOfContentsBy (Just . termFAnnotation) (patch deleting inserting replacing p) `shouldBe` - patch (fmap Deleted) (fmap Inserted) (\ as bs -> Replaced (head bs) : fmap Deleted (tail as) <> fmap Inserted (tail bs)) (bimap (foldMap pure) (foldMap pure) (p :: Patch (Term ListableSyntax Int) (Term ListableSyntax Int))) + patch (fmap (Deleted,)) (fmap (Inserted,)) (\ as bs -> (Replaced, head bs) : fmap (Deleted,) (tail as) <> fmap (Inserted,) (tail bs)) (bimap (foldMap pure) (foldMap pure) (p :: Patch (Term ListableSyntax Int) (Term ListableSyntax Int))) prop "produces changed entries for relevant nodes containing irrelevant patches" $ \ diff -> do let diff' = merge (True, True) (inject [bimap (const False) (const False) (diff :: Diff ListableSyntax Bool Bool)]) let toc = tableOfContentsBy (\ (n `In` _) -> if n then Just n else Nothing) diff' toc `shouldBe` if null (diffPatches diff') then [] - else [Changed True] + else [(Changed, True)] describe "diffTOC" $ do it "blank if there are no methods" $ @@ -60,40 +61,40 @@ spec = do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs diffTOC diff `shouldBe` - [ TOCSummary "Method" "self.foo" (Span (Pos 1 1) (Pos 2 4)) "added" - , TOCSummary "Method" "bar" (Span (Pos 4 1) (Pos 6 4)) "modified" - , TOCSummary "Method" "baz" (Span (Pos 4 1) (Pos 5 4)) "removed" + [ Right $ TOCSummary (Method Nothing) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted + , Right $ TOCSummary (Method Nothing) "bar" (Span (Pos 4 1) (Pos 6 4)) Changed + , Right $ TOCSummary (Method Nothing) "baz" (Span (Pos 4 1) (Pos 5 4)) Deleted ] it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")) diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs diffTOC diff `shouldBe` - [ TOCSummary "Function" "myFunction" (Span (Pos 1 1) (Pos 6 2)) "modified" ] + [ Right $ TOCSummary Function "myFunction" (Span (Pos 1 1) (Pos 6 2)) Changed ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")) diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs diffTOC diff `shouldBe` - [ TOCSummary "Function" "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) "modified" ] + [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Changed ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")) diff <- runTaskOrDie $ diffWithParser goParser sourceBlobs diffTOC diff `shouldBe` - [ TOCSummary "Method" "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) "added" ] + [ Right $ TOCSummary (Method Nothing) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")) diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs diffTOC diff `shouldBe` - [ TOCSummary "Method" "foo" (Span (Pos 1 1) (Pos 4 4)) "modified" ] + [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb")) diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs diffTOC diff `shouldBe` - [ TOCSummary "Method" "foo" (Span (Pos 6 1) (Pos 7 4)) "added" ] + [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 6 1) (Pos 7 4)) Inserted ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js")) @@ -130,11 +131,11 @@ spec = do describe "TOCSummary" $ do it "encodes modified summaries to JSON" $ do - let summary = TOCSummary "Method" "foo" (Span (Pos 1 1) (Pos 4 4)) "modified" + let summary = TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed encode summary `shouldBe` "{\"span\":{\"start\":[1,1],\"end\":[4,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"modified\"}" it "encodes added summaries to JSON" $ do - let summary = TOCSummary "Method" "self.foo" (Span (Pos 1 1) (Pos 2 4)) "added" + let summary = TOCSummary (Method Nothing) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted encode summary `shouldBe` "{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"}" describe "diff with ToCDiffRenderer'" $ do @@ -163,13 +164,13 @@ type Diff' = Diff ListableSyntax (Maybe Declaration) (Maybe Declaration) type Term' = Term ListableSyntax (Maybe Declaration) numTocSummaries :: Diff' -> Int -numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) +numTocSummaries diff = length $ filter isRight (diffTOC diff) -- Return a diff where body is inserted in the expressions of a function. The function is present in Both sides of the diff. programWithChange :: Term' -> Diff' programWithChange body = merge (Nothing, Nothing) (inject [ function' ]) where - function' = merge (Just (FunctionDeclaration "foo" mempty lowerBound Ruby), Just (FunctionDeclaration "foo" mempty lowerBound Ruby)) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [ inserting body ])))) + function' = merge (Just (Declaration Function "foo" mempty lowerBound Ruby), Just (Declaration Function "foo" mempty lowerBound Ruby)) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [ inserting body ])))) name' = merge (Nothing, Nothing) (inject (Syntax.Identifier (name "foo"))) -- Return a diff where term is inserted in the program, below a function found on Both sides of the diff. @@ -193,7 +194,7 @@ programOf :: Diff' -> Diff' programOf diff = merge (Nothing, Nothing) (inject [ diff ]) functionOf :: Text -> Term' -> Term' -functionOf n body = termIn (Just (FunctionDeclaration n mempty lowerBound Unknown)) (inject (Declaration.Function [] name' [] (termIn Nothing (inject [body])))) +functionOf n body = termIn (Just (Declaration Function n mempty lowerBound Unknown)) (inject (Declaration.Function [] name' [] (termIn Nothing (inject [body])))) where name' = termIn Nothing (inject (Syntax.Identifier (name n))) From 4e11968054ea4746ea472489abae8288f564e212 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 03:51:31 -0400 Subject: [PATCH 106/118] Correct the expectations. --- test/Rendering/TOC/Spec.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 3d2861afe..e4a31ca11 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -61,7 +61,7 @@ spec = do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs diffTOC diff `shouldBe` - [ Right $ TOCSummary (Method Nothing) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted + [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted , Right $ TOCSummary (Method Nothing) "bar" (Span (Pos 4 1) (Pos 6 4)) Changed , Right $ TOCSummary (Method Nothing) "baz" (Span (Pos 4 1) (Pos 5 4)) Deleted ] @@ -76,13 +76,13 @@ spec = do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")) diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs diffTOC diff `shouldBe` - [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Changed ] + [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Replaced ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")) diff <- runTaskOrDie $ diffWithParser goParser sourceBlobs diffTOC diff `shouldBe` - [ Right $ TOCSummary (Method Nothing) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] + [ Right $ TOCSummary (Method (Just "*apiClient")) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")) From 827210b255414136e97063c1340aae336c82e3db Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 04:02:18 -0400 Subject: [PATCH 107/118] Rename diffWithParser to runDiff. --- test/Rendering/TOC/Spec.hs | 41 +++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index e4a31ca11..3848d8fed 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -59,7 +59,7 @@ spec = do it "summarizes changed methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) - diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs + diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs diffTOC diff `shouldBe` [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted , Right $ TOCSummary (Method Nothing) "bar" (Span (Pos 4 1) (Pos 6 4)) Changed @@ -68,37 +68,37 @@ spec = do it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")) - diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs + diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs diffTOC diff `shouldBe` [ Right $ TOCSummary Function "myFunction" (Span (Pos 1 1) (Pos 6 2)) Changed ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")) - diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs + diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs diffTOC diff `shouldBe` [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Replaced ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")) - diff <- runTaskOrDie $ diffWithParser goParser sourceBlobs + diff <- runTaskOrDie $ runDiff goParser sourceBlobs diffTOC diff `shouldBe` [ Right $ TOCSummary (Method (Just "*apiClient")) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")) - diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs + diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs diffTOC diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb")) - diff <- runTaskOrDie $ diffWithParser rubyParser sourceBlobs + diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs diffTOC diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 6 1) (Pos 7 4)) Inserted ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js")) - diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs + diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs diffTOC diff `shouldBe` [] prop "inserts of methods and functions are summarized" . forAll ((not . isMethodOrFunction . Prelude.snd) `filterT` tiers) $ @@ -220,16 +220,17 @@ blankDiff :: Diff' blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject (Syntax.Identifier (name "\"a\"")))) ]) -- Diff helpers -diffWithParser :: ( Eq1 syntax - , Traversable syntax - , Diffable syntax - , HasDeclaration syntax - , Hashable1 syntax - , Member Distribute sig - , Member Parse sig - , Carrier sig m - ) - => Parser (Term syntax Loc) - -> BlobPair - -> m (Diff syntax (Maybe Declaration) (Maybe Declaration)) -diffWithParser parser blobs = diffTermPair . runJoin <$> distributeFor blobs (\ blob -> decoratorWithAlgebra (declarationAlgebra blob) <$> parse parser blob) +runDiff + :: ( Eq1 syntax + , Traversable syntax + , Diffable syntax + , HasDeclaration syntax + , Hashable1 syntax + , Member Distribute sig + , Member Parse sig + , Carrier sig m + ) + => Parser (Term syntax Loc) + -> BlobPair + -> m (Diff syntax (Maybe Declaration) (Maybe Declaration)) +runDiff parser blobs = diffTermPair . runJoin <$> distributeFor blobs (\ blob -> decoratorWithAlgebra (declarationAlgebra blob) <$> parse parser blob) From 132d8afc5c9601f3bfaa7c5298743dbaafdb5d43 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 04:04:54 -0400 Subject: [PATCH 108/118] Return the summaries directly from runDiff. --- test/Rendering/TOC/Spec.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 3848d8fed..c1d5d531b 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -60,7 +60,7 @@ spec = do it "summarizes changed methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs - diffTOC diff `shouldBe` + diff `shouldBe` [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted , Right $ TOCSummary (Method Nothing) "bar" (Span (Pos 4 1) (Pos 6 4)) Changed , Right $ TOCSummary (Method Nothing) "baz" (Span (Pos 4 1) (Pos 5 4)) Deleted @@ -69,37 +69,37 @@ spec = do it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")) diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs - diffTOC diff `shouldBe` + diff `shouldBe` [ Right $ TOCSummary Function "myFunction" (Span (Pos 1 1) (Pos 6 2)) Changed ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")) diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs - diffTOC diff `shouldBe` + diff `shouldBe` [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Replaced ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")) diff <- runTaskOrDie $ runDiff goParser sourceBlobs - diffTOC diff `shouldBe` + diff `shouldBe` [ Right $ TOCSummary (Method (Just "*apiClient")) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")) diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs - diffTOC diff `shouldBe` + diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb")) diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs - diffTOC diff `shouldBe` + diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 6 1) (Pos 7 4)) Inserted ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js")) diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs - diffTOC diff `shouldBe` [] + diff `shouldBe` [] prop "inserts of methods and functions are summarized" . forAll ((not . isMethodOrFunction . Prelude.snd) `filterT` tiers) $ \(name, body) -> @@ -232,5 +232,5 @@ runDiff ) => Parser (Term syntax Loc) -> BlobPair - -> m (Diff syntax (Maybe Declaration) (Maybe Declaration)) -runDiff parser blobs = diffTermPair . runJoin <$> distributeFor blobs (\ blob -> decoratorWithAlgebra (declarationAlgebra blob) <$> parse parser blob) + -> m [Either ErrorSummary TOCSummary] +runDiff parser blobs = diffTOC . diffTermPair . runJoin <$> distributeFor blobs (\ blob -> decoratorWithAlgebra (declarationAlgebra blob) <$> parse parser blob) From 02800fe8109896429deb3cf7762a0a4d0e0d7bd8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 04:10:29 -0400 Subject: [PATCH 109/118] Abstract over the parser in the tests. --- test/Rendering/TOC/Spec.hs | 38 +++++++++++--------------------------- 1 file changed, 11 insertions(+), 27 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index c1d5d531b..d1479ef3d 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -1,28 +1,21 @@ {-# LANGUAGE DataKinds, MonoLocalBinds, TupleSections, TypeOperators #-} module Rendering.TOC.Spec (spec) where -import Analysis.Decorator import Analysis.TOCSummary -import Control.Effect -import Control.Effect.Parse import Data.Aeson hiding (defaultOptions) import Data.Bifunctor -import Data.Bifunctor.Join import Data.Diff import Data.Either (isRight) -import Data.Functor.Classes -import Data.Hashable.Lifted import Data.Patch import Data.Sum import Data.Term import Data.Text (Text) -import Diffing.Algorithm hiding (Diff) import Diffing.Interpreter import Prelude import qualified Data.Syntax as Syntax import qualified Data.Syntax.Declaration as Declaration import Rendering.TOC -import Semantic.Api (diffSummaryBuilder) +import Semantic.Api (DiffEffects, decorateTerm, decoratingDiffWith, diffSummaryBuilder, summarizeDiff, summarizeDiffParsers) import Serializing.Format as Format import Source.Loc import Source.Span @@ -59,7 +52,7 @@ spec = do it "summarizes changed methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) - diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs + diff <- runTaskOrDie $ runDiff sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted , Right $ TOCSummary (Method Nothing) "bar" (Span (Pos 4 1) (Pos 6 4)) Changed @@ -68,37 +61,37 @@ spec = do it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")) - diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs + diff <- runTaskOrDie $ runDiff sourceBlobs diff `shouldBe` [ Right $ TOCSummary Function "myFunction" (Span (Pos 1 1) (Pos 6 2)) Changed ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")) - diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs + diff <- runTaskOrDie $ runDiff sourceBlobs diff `shouldBe` [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Replaced ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")) - diff <- runTaskOrDie $ runDiff goParser sourceBlobs + diff <- runTaskOrDie $ runDiff sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method (Just "*apiClient")) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")) - diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs + diff <- runTaskOrDie $ runDiff sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb")) - diff <- runTaskOrDie $ runDiff rubyParser sourceBlobs + diff <- runTaskOrDie $ runDiff sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 6 1) (Pos 7 4)) Inserted ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js")) - diff <- runTaskOrDie $ runDiff typescriptParser sourceBlobs + diff <- runTaskOrDie $ runDiff sourceBlobs diff `shouldBe` [] prop "inserts of methods and functions are summarized" . forAll ((not . isMethodOrFunction . Prelude.snd) `filterT` tiers) $ @@ -221,16 +214,7 @@ blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject -- Diff helpers runDiff - :: ( Eq1 syntax - , Traversable syntax - , Diffable syntax - , HasDeclaration syntax - , Hashable1 syntax - , Member Distribute sig - , Member Parse sig - , Carrier sig m - ) - => Parser (Term syntax Loc) - -> BlobPair + :: DiffEffects sig m + => BlobPair -> m [Either ErrorSummary TOCSummary] -runDiff parser blobs = diffTOC . diffTermPair . runJoin <$> distributeFor blobs (\ blob -> decoratorWithAlgebra (declarationAlgebra blob) <$> parse parser blob) +runDiff = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff) From f2dabc74e44d74819be3046f4c1051a242cb2668 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 04:13:55 -0400 Subject: [PATCH 110/118] Rename runDiff to summarize. --- test/Rendering/TOC/Spec.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index d1479ef3d..f4a0da5e5 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -52,7 +52,7 @@ spec = do it "summarizes changed methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) - diff <- runTaskOrDie $ runDiff sourceBlobs + diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted , Right $ TOCSummary (Method Nothing) "bar" (Span (Pos 4 1) (Pos 6 4)) Changed @@ -61,37 +61,37 @@ spec = do it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")) - diff <- runTaskOrDie $ runDiff sourceBlobs + diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary Function "myFunction" (Span (Pos 1 1) (Pos 6 2)) Changed ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")) - diff <- runTaskOrDie $ runDiff sourceBlobs + diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Replaced ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")) - diff <- runTaskOrDie $ runDiff sourceBlobs + diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method (Just "*apiClient")) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")) - diff <- runTaskOrDie $ runDiff sourceBlobs + diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb")) - diff <- runTaskOrDie $ runDiff sourceBlobs + diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 6 1) (Pos 7 4)) Inserted ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js")) - diff <- runTaskOrDie $ runDiff sourceBlobs + diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [] prop "inserts of methods and functions are summarized" . forAll ((not . isMethodOrFunction . Prelude.snd) `filterT` tiers) $ @@ -213,8 +213,8 @@ blankDiff :: Diff' blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject (Syntax.Identifier (name "\"a\"")))) ]) -- Diff helpers -runDiff +summarize :: DiffEffects sig m => BlobPair -> m [Either ErrorSummary TOCSummary] -runDiff = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff) +summarize = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff) From cfb9151d0f52a52403c1cc03cc95dfdee53d52e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 04:23:49 -0400 Subject: [PATCH 111/118] :fire: redundant deriving strategies. --- src/Rendering/TOC.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 0fd9850ca..bb5fe35b8 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -23,7 +23,7 @@ import qualified Data.Text as T import Source.Loc data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] } - deriving stock (Eq, Show, Generic) + deriving (Eq, Show, Generic) deriving Semigroup via GenericSemigroup Summaries deriving Monoid via GenericMonoid Summaries @@ -36,14 +36,14 @@ data TOCSummary = TOCSummary , span :: Span , change :: Change } - deriving stock (Eq, Show) + deriving (Eq, Show) data ErrorSummary = ErrorSummary { message :: T.Text , span :: Span , language :: Language } - deriving stock (Eq, Show) + deriving (Eq, Show) instance ToJSON TOCSummary where toJSON TOCSummary{..} = object [ "changeType" .= change, "category" .= formatKind kind, "term" .= ident, "span" .= span ] From a559479779beef4aa9946ac08f30d9f940e4f1cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 04:24:17 -0400 Subject: [PATCH 112/118] Align. --- src/Rendering/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index bb5fe35b8..23e70f5ae 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -25,7 +25,7 @@ import Source.Loc data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] } deriving (Eq, Show, Generic) deriving Semigroup via GenericSemigroup Summaries - deriving Monoid via GenericMonoid Summaries + deriving Monoid via GenericMonoid Summaries instance ToJSON Summaries where toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ] From 073bf89ee8a0ed5e3e8ba5203bcefebe6d8793ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 04:25:38 -0400 Subject: [PATCH 113/118] Move formatIdentifier to Analysis.TOCSummary. --- src/Analysis/TOCSummary.hs | 8 ++++++++ src/Rendering/TOC.hs | 7 ------- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 0e529a365..f9ce49945 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.TOCSummary ( Declaration(..) +, formatIdentifier , Kind(..) , formatKind , HasDeclaration @@ -33,6 +34,13 @@ data Declaration = Declaration , language :: Language } deriving (Eq, Show) +formatIdentifier :: Declaration -> Text +formatIdentifier (Declaration kind identifier _ _ lang) = case kind of + Method (Just receiver) + | Language.Go <- lang -> "(" <> receiver <> ") " <> identifier + | otherwise -> receiver <> "." <> identifier + _ -> identifier + data Kind = Method (Maybe Text) | Function diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 23e70f5ae..aeaa4c836 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -116,12 +116,5 @@ recordSummary change decl@(Declaration kind text _ srcSpan language) | Error <- kind = Left $ ErrorSummary text srcSpan language | otherwise = Right $ TOCSummary kind (formatIdentifier decl) srcSpan change -formatIdentifier :: Declaration -> Text -formatIdentifier (Declaration kind identifier _ _ lang) = case kind of - Method (Just receiver) - | Language.Go <- lang -> "(" <> receiver <> ") " <> identifier - | otherwise -> receiver <> "." <> identifier - _ -> identifier - diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [Either ErrorSummary TOCSummary] diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration From 0759211f51075df9a6805526e307ed98a9143f6c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 05:05:02 -0400 Subject: [PATCH 114/118] Fix a broken bound. --- semantic.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/semantic.cabal b/semantic.cabal index 86020ddea..dc5874931 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -71,7 +71,7 @@ common dependencies , text ^>= 1.2.3.1 , these >= 0.7 && <1 , unix ^>= 2.7.2.2 - , lingo >= 0.2.0.0 + , lingo ^>= 0.2 common executable-flags ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" From 3d1732a061fbe02ab133f4faeaa1c29a4975fa02 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 19:37:58 -0400 Subject: [PATCH 115/118] Use the queswish operator. Co-Authored-By: Patrick Thomson --- src/Semantic/Api/TOCSummaries.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index da2f4d5c8..e48648e09 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -61,7 +61,7 @@ toChange :: TOCSummary -> TOCSummaryChange toChange TOCSummary{..} = defMessage & P.category .~ formatKind kind & P.term .~ ident - & P.maybe'span .~ (converting #? span) + & P.maybe'span ?~ converting # span & P.changeType .~ toChangeType change toError :: ErrorSummary -> TOCSummaryError From 7ab069576626c5bfeca1153eea61807f0c76132e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 19:38:34 -0400 Subject: [PATCH 116/118] More queswish. Co-Authored-By: Patrick Thomson --- src/Semantic/Api/TOCSummaries.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index e48648e09..10a3a9793 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -67,4 +67,4 @@ toChange TOCSummary{..} = defMessage toError :: ErrorSummary -> TOCSummaryError toError ErrorSummary{..} = defMessage & P.error .~ message - & P.maybe'span .~ converting #? span + & P.maybe'span ?~ converting # span From fbfcdd89853d1c109958f2da33df81a09fdf331f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 21:59:35 -0400 Subject: [PATCH 117/118] LambdaCase. --- src/Analysis/TOCSummary.hs | 4 ++-- src/Rendering/TOC.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index f9ce49945..6cdf03df5 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.TOCSummary ( Declaration(..) , formatIdentifier @@ -49,7 +49,7 @@ data Kind deriving (Eq, Ord, Show) formatKind :: Kind -> T.Text -formatKind kind = case kind of +formatKind = \case Function -> "Function" Method _ -> "Method" Heading l -> "Heading " <> T.pack (show l) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index aeaa4c836..6a32f2a6a 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingVia, DuplicateRecordFields, RankNTypes, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE DerivingVia, DuplicateRecordFields, LambdaCase, RankNTypes, ScopedTypeVariables, TupleSections #-} module Rendering.TOC ( diffTOC , Summaries(..) @@ -60,7 +60,7 @@ data Change deriving (Eq, Show) instance ToJSON Change where - toJSON change = case change of + toJSON = \case Changed -> "modified" Deleted -> "removed" Inserted -> "added" From 8a3c49f3dfc8c275f1974766122153459e487fdc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Oct 2019 22:03:02 -0400 Subject: [PATCH 118/118] Reformat dedupe. --- src/Rendering/TOC.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 6a32f2a6a..30616c479 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -101,7 +101,12 @@ data Dedupe = Dedupe -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. dedupe :: [(Change, Declaration)] -> [(Change, Declaration)] -dedupe = map ((change :: Dedupe -> Change) &&& decl) . sortOn index . Map.elems . foldl' go Map.empty . zipWith (uncurry . Dedupe) [0..] where +dedupe + = map ((change :: Dedupe -> Change) &&& decl) -- extract the changes and decls + . sortOn index -- after sorting + . Map.elems -- the elements of the map + . foldl' go Map.empty -- produced by deduping + . zipWith (uncurry . Dedupe) [0..] where -- the indexed inputs go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case Map.lookup key m of Just (Dedupe _ _ similar) | similar == decl -> m