Merge pull request #346 from github/toc-this-way

ToC refactoring

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"

src/Analysis/TOCSummary.hs

@@ -1,6 +1,9 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.TOCSummary
 ( Declaration(..)
+, formatIdentifier
+, Kind(..)
+, formatKind
 , HasDeclaration
 , declarationAlgebra
 ) where
@@ -10,111 +13,129 @@ 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
 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
+data Declaration = Declaration
-  = MethodDeclaration   { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationReceiver :: Maybe Text }
+  { kind       :: Kind
-  | FunctionDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
+  , identifier :: Text
-  | HeadingDeclaration  { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int }
+  , text       :: Text
-  | ErrorDeclaration    { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
+  , span       :: Span
-  deriving (Eq, Generic, Show)
+  , 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
+  | Heading Int
+  | Error
+  deriving (Eq, Ord, Show)
+
+formatKind :: Kind -> T.Text
+formatKind = \case
+  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.
 --
 --   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
+-- | 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.
-class HasDeclaration syntax where
-  toDeclaration :: (Foldable syntax) => Blob -> Loc -> syntax (Term syntax Loc, Maybe Declaration) -> Maybe Declaration
-
-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.
 --
 --   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').
+  -- | 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
+  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, HasDeclarationWithStrategy strategy whole syntax) => HasDeclaration' whole syntax where
+instance (DeclarationStrategy syntax ~ strategy, HasDeclarationBy strategy syntax) => HasDeclaration syntax where
-  toDeclaration' = toDeclarationWithStrategy (Proxy :: Proxy strategy)
+  toDeclaration = toDeclarationBy @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).
+-- | Produce a 'Declaration' for a syntax node using either the 'Default' or 'Custom' strategy.
-class CustomHasDeclaration whole syntax where
+class HasDeclarationBy (strategy :: Strategy) syntax where
-  -- | Produce a customized 'Declaration' for a given syntax node.
+  toDeclarationBy :: 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
+
+-- | The 'Default' strategy produces 'Nothing'.
+instance HasDeclarationBy 'Default syntax where
+  toDeclarationBy _ _ _ = Nothing
 
 
--- | 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
+instance HasDeclarationBy 'Custom Markdown.Heading where
-  customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _)
+  toDeclarationBy blob@Blob{..} ann (Markdown.Heading level terms _)
-    = Just $ HeadingDeclaration (headingText terms) mempty (Loc.span ann) (blobLanguage blob) level
+    = 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
+instance HasDeclarationBy 'Custom Syntax.Error where
-  customToDeclaration blob@Blob{..} ann err@Syntax.Error{}
+  toDeclarationBy 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 Error (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').
+-- | 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 HasDeclarationBy 'Custom Declaration.Function where
-  customToDeclaration 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
-    | otherwise             = Just $ 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 'declarationIdentifier' 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
+instance HasDeclarationBy 'Custom Declaration.Method where
-  customToDeclaration 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 $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) Nothing
+    | 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 $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) (Just (getSource blobSource receiverType))
+    , [ _, 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 $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) (Just (getSource blobSource receiverAnn))
+    | 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)
 
 -- 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
@@ -132,39 +153,23 @@ 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'.
+-- | 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' whole) fs => CustomHasDeclaration whole (Sum fs) where
+instance Apply HasDeclaration fs => HasDeclarationBy 'Custom (Sum fs) where
-  customToDeclaration blob ann = apply @(HasDeclaration' whole) (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@.
 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
-  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.
 --
 --   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
+  DeclarationStrategy Declaration.Method   = 'Custom
-  DeclarationStrategy Markdown.Heading = 'Custom
+  DeclarationStrategy Markdown.Heading     = 'Custom
-  DeclarationStrategy Syntax.Error = 'Custom
+  DeclarationStrategy Syntax.Error         = 'Custom
-  DeclarationStrategy (Sum fs) = 'Custom
+  DeclarationStrategy (Sum fs)             = 'Custom
-  DeclarationStrategy a = 'Default
+  DeclarationStrategy a                    = 'Default
-
-
--- | The 'Default' strategy produces 'Nothing'.
-instance HasDeclarationWithStrategy 'Default whole 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
-  toDeclarationWithStrategy _ = customToDeclaration

src/Rendering/TOC.hs

@@ -1,28 +1,21 @@
-{-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE DerivingVia, DuplicateRecordFields, LambdaCase, RankNTypes, ScopedTypeVariables, TupleSections #-}
 module Rendering.TOC
-( renderToCDiff
+( diffTOC
-, diffTOC
 , Summaries(..)
 , TOCSummary(..)
-, isValidSummary
+, ErrorSummary(..)
-, declaration
+, Change(..)
-, Entry(..)
 , tableOfContentsBy
-, termTableOfContentsBy
 , dedupe
-, entrySummary
-, toCategoryName
 ) where
 
-import Prologue
+import Prologue hiding (index)
 import Analysis.TOCSummary
 import Data.Align (bicrosswalk)
-import Data.Aeson
+import Data.Aeson (ToJSON(..), Value, (.=), object)
-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
@@ -30,66 +23,75 @@ 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
+  deriving Monoid    via GenericMonoid    Summaries
 
 instance ToJSON Summaries where
   toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ]
 
-data TOCSummary
+data TOCSummary = TOCSummary
-  = TOCSummary
+  { kind   :: Kind
-    { summaryCategoryName :: T.Text
+  , ident  :: T.Text
-    , summaryTermName :: T.Text
+  , span   :: Span
-    , summarySpan :: Span
+  , change :: Change
-    , summaryChangeType :: T.Text
+  }
-    }
+  deriving (Eq, Show)
-  | ErrorSummary { errorText :: T.Text, errorSpan :: Span, errorLanguage :: Language }
+
-  deriving stock (Generic, Eq, Show)
+data ErrorSummary = ErrorSummary
+  { message  :: T.Text
+  , span     :: Span
+  , language :: Language
+  }
+  deriving (Eq, Show)
 
 instance ToJSON TOCSummary where
-  toJSON TOCSummary{..} = object [ "changeType" .= summaryChangeType, "category" .= summaryCategoryName, "term" .= summaryTermName, "span" .= summarySpan ]
+  toJSON TOCSummary{..} = object [ "changeType" .= change, "category" .= formatKind kind, "term" .= ident, "span" .= span ]
-  toJSON ErrorSummary{..} = object [ "error" .= errorText, "span" .= errorSpan, "language" .= errorLanguage ]
+
+instance ToJSON ErrorSummary where
+  toJSON ErrorSummary{..} = object [ "error" .= message, "span" .= span, "language" .= language ]
+
+-- | The kind of a ToC change.
+data Change
+  = Changed
+  | Inserted
+  | Deleted
+  | Replaced
+  deriving (Eq, Show)
+
+instance ToJSON Change where
+  toJSON = \case
+    Changed  -> "modified"
+    Deleted  -> "removed"
+    Inserted -> "added"
+    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
 
-
--- | 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'.
-  deriving (Eq, Show)
-
-
 -- | 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.
                   -> 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.
+                  -> [(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
-    (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)
-                      -> 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)
+data DedupeKey = DedupeKey !Kind {-# UNPACK #-} !T.Text
+  deriving (Eq, Ord)
+
+data Dedupe = Dedupe
+  { index  :: {-# UNPACK #-} !Int
+  , change :: !Change
+  , decl   :: {-# UNPACK #-} !Declaration
+  }
 
 -- Dedupe entries in a final pass. This catches two specific scenarios with
 -- different behaviors:
@@ -98,54 +100,26 @@ 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 :: [(Change, Declaration)] -> [(Change, Declaration)]
-dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in (fmap . fmap) snd tuples
+dedupe
-  where
+  = map ((change :: Dedupe -> Change) &&& decl) -- extract the changes and decls
-    go :: (Int, Map.Map DedupeKey (Int, Entry Declaration))
+  . sortOn index                                -- after sorting
-       -> Entry Declaration
+  . Map.elems                                   -- the elements of the map
-       -> (Int, Map.Map DedupeKey (Int, Entry Declaration))
+  . foldl' go Map.empty                         -- produced by deduping
-    go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey x) m
+  . zipWith (uncurry . Dedupe) [0..] where      -- the indexed inputs
-                    = if exactMatch similar x
+  go m d@(Dedupe _ _ decl) = let key = dedupeKey decl in case Map.lookup key m of
-                      then (succ index, m)
+    Just (Dedupe _ _ similar)
-                      else
+      | similar == decl -> m
-                        let replacement = Replaced (entryPayload similar)
+      | otherwise       -> Map.insert key d { change = Replaced, decl = similar } m
-                        in (succ index, Map.insert (dedupeKey replacement) (index, replacement) m)
+    _                   -> Map.insert key d m
-                    | otherwise = (succ index, Map.insert (dedupeKey x) (index, x) m)
 
-    dedupeKey entry = DedupeKey (toCategoryName (entryPayload entry), T.toLower (declarationIdentifier (entryPayload entry)))
+  dedupeKey (Declaration kind ident _ _ _) = DedupeKey kind (T.toLower ident)
-    exactMatch = (==) `on` entryPayload
-
--- | 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 'TOCSummary' from a node annotation and a change type label.
-recordSummary :: T.Text -> Declaration -> TOCSummary
+recordSummary :: Change -> Declaration -> Either ErrorSummary TOCSummary
-recordSummary changeText record = case record of
+recordSummary change decl@(Declaration kind text _ srcSpan language)
-  (ErrorDeclaration text _ srcSpan language) -> ErrorSummary text srcSpan language
+  | Error <- kind = Left  $ ErrorSummary text srcSpan language
-  decl-> TOCSummary (toCategoryName decl) (formatIdentifier decl) (declarationSpan decl) changeText
+  | otherwise     = Right $ TOCSummary kind (formatIdentifier decl) srcSpan change
-  where
-    formatIdentifier (MethodDeclaration identifier _ _ Language.Go (Just receiver)) = "(" <> receiver <> ") " <> identifier
-    formatIdentifier (MethodDeclaration identifier _ _ _           (Just receiver)) = receiver <> "." <> identifier
-    formatIdentifier decl = declarationIdentifier decl
 
-renderToCDiff :: (Foldable f, Functor f) => BlobPair -> Diff f (Maybe Declaration) (Maybe Declaration) -> Summaries
+diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [Either ErrorSummary TOCSummary]
-renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
+diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration
-  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 = fmap entrySummary . 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"

src/Semantic/Api/Diffs.hs

@@ -7,8 +7,6 @@ module Semantic.Api.Diffs
   , decoratingDiffWith
   , DiffEffects
 
-  , legacySummarizeDiffParsers
-  , LegacySummarizeDiff(..)
   , summarizeDiffParsers
   , SummarizeDiff(..)
   ) where
@@ -151,50 +149,16 @@ 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 = renderToCDiff
-
-
 summarizeDiffParsers :: Map Language (SomeParser SummarizeDiff Loc)
 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) -> [Either ErrorSummary 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)
+  summarizeDiff = diffTOC
-    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
 
 
 -- | Parse a 'BlobPair' using one of the provided parsers, diff the resulting terms, and run an action on the abstracted diff.

src/Semantic/Api/TOCSummaries.hs

@@ -1,10 +1,13 @@
+{-# LANGUAGE LambdaCase #-}
 module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
 
+import           Analysis.TOCSummary (formatKind)
 import           Control.Effect.Error
 import           Control.Lens
 import           Data.Aeson
 import           Data.Blob
 import           Data.ByteString.Builder
+import           Data.Either (partitionEithers)
 import qualified Data.Map.Monoidal as Map
 import           Data.ProtoLens (defMessage)
 import           Data.Semilattice.Lower
@@ -23,26 +26,45 @@ 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 (flip Summaries) . bimap toMap toMap . partitionEithers . summarizeDiff) blobPair
-    go blobPair = decoratingDiffWith legacySummarizeDiffParsers legacyDecorateTerm (pure . legacySummarizeDiff blobPair) 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
 
+            toMap [] = mempty
+            toMap as = Map.singleton path (toJSON <$> as)
+
 
 diffSummary :: DiffEffects sig m => [BlobPair] -> m DiffTreeTOCResponse
 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 . uncurry toFile . partitionEithers . map (bimap toError toChange) . summarizeDiff) blobPair
-    go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff blobPair) blobPair
       `catchError` \(SomeException e) ->
-        pure $ defMessage
+        pure $ toFile [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] []
-          & P.path .~ path
+      where toFile errors changes = defMessage
-          & P.language .~ lang
+              & P.path     .~ T.pack (pathKeyForBlobPair blobPair)
-          & P.changes .~ mempty
+              & P.language .~ bridging # languageForBlobPair blobPair
-          & P.errors .~ [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing]
+              & P.changes  .~ changes
-      where path = T.pack $ pathKeyForBlobPair blobPair
+              & P.errors   .~ errors
-            lang = bridging # languageForBlobPair blobPair
+
+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
+
+toError :: ErrorSummary -> TOCSummaryError
+toError ErrorSummary{..} = defMessage
+  & P.error      .~ message
+  & P.maybe'span ?~ converting # span

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
+    =  cons1 ToC.Method
-    \/ cons4 FunctionDeclaration
+    \/ cons0 ToC.Function
-    \/ cons3 (\ a b c -> ErrorDeclaration a b c Language.Unknown)
+    \/ cons0 ToC.Error
 
 instance Listable Language.Language where
   tiers

test/Rendering/TOC/Spec.hs

@@ -1,27 +1,21 @@
-{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-}
+{-# 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.Functor.Classes
+import Data.Either (isRight)
-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
@@ -43,14 +37,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" $
@@ -58,56 +52,47 @@ 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 $ summarize sourceBlobs
-      diffTOC diff `shouldBe`
+      diff `shouldBe`
-        [ TOCSummary "Method" "self.foo" (Span (Pos 1 1) (Pos 2 4)) "added"
+        [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted
-        , TOCSummary "Method" "bar" (Span (Pos 4 1) (Pos 6 4)) "modified"
+        , Right $ TOCSummary (Method Nothing) "bar" (Span (Pos 4 1) (Pos 6 4)) Changed
-        , TOCSummary "Method" "baz" (Span (Pos 4 1) (Pos 5 4)) "removed"
+        , Right $ TOCSummary (Method Nothing) "baz" (Span (Pos 4 1) (Pos 5 4)) Deleted
-        ]
-
-    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
+      diff <- runTaskOrDie $ summarize sourceBlobs
-      diffTOC diff `shouldBe`
+      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
+      diff <- runTaskOrDie $ summarize sourceBlobs
-      diffTOC diff `shouldBe`
+      diff `shouldBe`
-        [ TOCSummary "Function" "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) "modified" ]
+        [ 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 $ summarize sourceBlobs
-      diffTOC diff `shouldBe`
+      diff `shouldBe`
-        [ TOCSummary "Method" "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) "added" ]
+        [ 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 $ summarize sourceBlobs
-      diffTOC diff `shouldBe`
+      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
+      diff <- runTaskOrDie $ summarize sourceBlobs
-      diffTOC diff `shouldBe`
+      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"))
-      diff <- runTaskOrDie $ diffWithParser typescriptParser sourceBlobs
+      diff <- runTaskOrDie $ summarize sourceBlobs
-      diffTOC diff `shouldBe` []
+      diff `shouldBe` []
 
     prop "inserts of methods and functions are summarized" . forAll ((not . isMethodOrFunction . Prelude.snd) `filterT` tiers) $
       \(name, body) ->
@@ -139,11 +124,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
@@ -172,13 +157,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.
@@ -202,7 +187,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)))
 
@@ -228,16 +213,8 @@ blankDiff :: Diff'
 blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject (Syntax.Identifier (name "\"a\"")))) ])
 
 -- Diff helpers
-diffWithParser :: ( Eq1 syntax
+summarize
-                  , Traversable syntax
+  :: DiffEffects sig m
-                  , Diffable syntax
+  => BlobPair
-                  , HasDeclaration syntax
+  -> m [Either ErrorSummary TOCSummary]
-                  , Hashable1 syntax
+summarize = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff)
-                  , 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)