Merge pull request #941 from github/table-of-contents

Table of contents

semantic-diff.cabal

@@ -48,6 +48,7 @@ library
                      , Renderer.Split
                      , Renderer.Summary
                      , Renderer.SExpression
+                     , Renderer.TOC
                      , SemanticDiff
                      , SES
                      , Source

src/Diffing.hs

@@ -18,6 +18,7 @@ import Renderer.Patch
 import Renderer.Split
 import Renderer.Summary
 import Renderer.SExpression
+import Renderer.TOC
 import Source
 import Syntax
 import System.Directory
@@ -78,6 +79,7 @@ textDiff parser arguments = diffFiles parser $ case format arguments of
   SExpression -> sExpression
   JSON -> json
   Summary -> summary
+  TOC -> toc
 
 -- | Returns a truncated diff given diff arguments and two source blobs.
 truncatedDiff :: DiffArguments -> Both SourceBlob -> IO Output
@@ -87,6 +89,7 @@ truncatedDiff arguments sources = pure $ case format arguments of
   SExpression -> SExpressionOutput mempty
   JSON -> JSONOutput mempty
   Summary -> SummaryOutput mempty
+  TOC -> TOCOutput mempty
 
 -- | Prints a rendered diff to stdio or a filepath given a parser, diff arguments and two source blobs.
 printDiff :: (ToJSON (Record fields), DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO ()
@@ -99,6 +102,7 @@ printDiff parser arguments sources = do
       SExpressionOutput text -> text
       JSONOutput series -> encodingToText (toJSON series)
       SummaryOutput summaries -> encodingToText (toJSON summaries)
+      TOCOutput summaries -> encodingToText (toJSON summaries)
   where
     -- TODO: Don't go from Value to Text?
     encodingToText = toS . encodingToLazyByteString . toEncoding

src/Patch.hs

@@ -6,11 +6,13 @@ module Patch
 , deleting
 , after
 , before
+, afterOrBefore
 , unPatch
 , patchSum
 , maybeFst
 , maybeSnd
 , mapPatch
+, patchType
 ) where
 
 import Data.Functor.Listable
@@ -48,6 +50,12 @@ after = maybeSnd . unPatch
 before :: Patch a -> Maybe a
 before = maybeFst . unPatch
 
+afterOrBefore :: Patch a -> Maybe a
+afterOrBefore patch = case (before patch, after patch) of
+  (_, Just after) -> Just after
+  (Just before, _) -> Just before
+  (_, _) -> Nothing
+
 -- | Return both sides of a patch.
 unPatch :: Patch a -> These a a
 unPatch (Replace a b) = These a b
@@ -71,6 +79,11 @@ maybeFst = these Just (const Nothing) ((Just .) . const)
 maybeSnd :: These a b -> Maybe b
 maybeSnd = these (const Nothing) Just ((Just .) . flip const)
 
+patchType :: Patch a -> Text
+patchType = \case
+  Replace{} -> "modified"
+  Insert{} -> "added"
+  Delete{} -> "removed"
 
 -- Instances
 

src/Renderer.hs

@@ -17,10 +17,10 @@ data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath
  deriving (Show)
 
 -- | The available types of diff rendering.
-data Format = Split | Patch | JSON | Summary | SExpression
+data Format = Split | Patch | JSON | Summary | SExpression | TOC
   deriving (Show)
 
-data Output = SplitOutput Text | PatchOutput Text | JSONOutput (Map Text Value) | SummaryOutput (Map Text (Map Text [Value])) | SExpressionOutput Text
+data Output = SplitOutput Text | PatchOutput Text | JSONOutput (Map Text Value) | SummaryOutput (Map Text (Map Text [Value])) | SExpressionOutput Text | TOCOutput (Map Text (Map Text [Value]))
   deriving (Show)
 
 -- Returns a key representing the filename. If the filenames are different,
@@ -49,6 +49,7 @@ concatOutputs list | isSummary list = toS . encodingToLazyByteString . toEncodin
   where
     concatSummaries :: [Output] -> Map Text (Map Text [Value])
     concatSummaries (SummaryOutput hash : rest) = Map.unionWith (Map.unionWith (<>)) hash (concatSummaries rest)
+    concatSummaries (TOCOutput hash : rest) = Map.unionWith (Map.unionWith (<>)) hash (concatSummaries rest)
     concatSummaries _ = mempty
 concatOutputs list | isText list = T.intercalate "\n" (toText <$> list)
 concatOutputs _ = mempty
@@ -59,6 +60,7 @@ isJSON _ = False
 
 isSummary :: [Output] -> Bool
 isSummary (SummaryOutput _ : _) = True
+isSummary (TOCOutput _ : _) = True
 isSummary _ = False
 
 isText :: [Output] -> Bool

src/Renderer/TOC.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Renderer.TOC (toc) where
+
+import Category as C
+import Data.Aeson
+import Data.Functor.Both hiding (fst, snd)
+import qualified Data.Functor.Both as Both
+import Data.Record
+import Diff
+import Info
+import Prologue
+import qualified Data.List as List
+import qualified Data.Map as Map hiding (null)
+import Renderer
+import Source
+import Syntax as S
+import Term
+import Patch
+import Unsafe (unsafeHead)
+
+data JSONSummary = JSONSummary { info :: Summarizable }
+                 | ErrorSummary { error :: Text, errorSpan :: SourceSpan }
+                 deriving (Generic, Eq, Show)
+
+instance ToJSON JSONSummary where
+  toJSON JSONSummary{..} = object $ case info of
+    InSummarizable{..} -> [ "changeType" .= ("modified" :: Text), "category" .= (show parentCategory :: Text), "term" .= parentTermName, "span" .= parentSourceSpan ]
+    Summarizable{..} -> [ "changeType" .= summarizableChangeType, "category" .= (show summarizableCategory :: Text), "term" .= summarizableTermName, "span" .= summarizableSourceSpan ]
+    NotSummarizable -> panic "NotSummarizable should have been pruned"
+  toJSON ErrorSummary{..} = object [ "error" .= error, "span" .= errorSpan ]
+
+isErrorSummary :: JSONSummary -> Bool
+isErrorSummary ErrorSummary{} = True
+isErrorSummary _ = False
+
+data DiffInfo = LeafInfo { leafCategory :: Category, termName :: Text, leafSourceSpan :: SourceSpan }
+ | BranchInfo { branches :: [ DiffInfo ], branchCategory :: Category }
+ | ErrorInfo { infoSpan :: SourceSpan, termName :: Text }
+ deriving (Eq, Show)
+
+data TOCSummary a = TOCSummary {
+                      summaryPatch :: Patch a,
+                      parentInfo :: Summarizable
+                    } deriving (Eq, Functor, Show, Generic)
+
+data Summarizable = Summarizable { summarizableCategory :: Category, summarizableTermName :: Text, summarizableSourceSpan :: SourceSpan, summarizableChangeType :: Text }
+  | InSummarizable { parentCategory :: Category, parentTermName :: Text, parentSourceSpan :: SourceSpan }
+  | NotSummarizable
+  deriving (Eq, Show)
+
+data SummarizableTerm a = SummarizableTerm a | NotSummarizableTerm a
+
+toc :: (DefaultFields fields) => Renderer (Record fields)
+toc blobs diff = TOCOutput $ Map.fromList [
+    ("changes", changes),
+    ("errors", errors)
+  ]
+  where
+    changes = if null changes' then mempty else Map.singleton summaryKey (toJSON <$> changes')
+    errors = if null errors' then mempty else Map.singleton summaryKey (toJSON <$> errors')
+    (errors', changes') = List.partition isErrorSummary summaries
+    summaryKey = toSummaryKey (path <$> blobs)
+    summaries = diffTOC blobs diff
+
+diffTOC :: (StringConv leaf Text, DefaultFields fields) => Both SourceBlob -> SyntaxDiff leaf fields -> [JSONSummary]
+diffTOC blobs diff = toJSONSummaries =<< removeDupes (diffToTOCSummaries (source <$> blobs) diff)
+  where
+    removeDupes :: [TOCSummary DiffInfo] -> [TOCSummary DiffInfo]
+    removeDupes [] = []
+    removeDupes xs = (fmap unsafeHead . List.groupBy (\a b -> parentInfo a == parentInfo b)) xs
+
+    diffToTOCSummaries :: (StringConv leaf Text, DefaultFields fields) => Both (Source Char) -> SyntaxDiff leaf fields -> [TOCSummary DiffInfo]
+    diffToTOCSummaries sources = para $ \diff ->
+      let
+        diff' = free (Prologue.fst <$> diff)
+        patch' = mapPatch (termToDiffInfo beforeSource) (termToDiffInfo afterSource)
+        (beforeSource, afterSource) = runJoin sources
+      in case diff of
+        (Free (_ :< syntax)) -> mapToInSummarizable sources diff' (toList syntax >>= snd)
+        (Pure patch) -> toTOCSummaries (patch' patch)
+
+-- Mark which leaves are summarizable.
+toTOCSummaries :: Patch DiffInfo -> [TOCSummary DiffInfo]
+toTOCSummaries patch = case afterOrBefore patch of
+  Just diffInfo -> toTOCSummaries' diffInfo
+  Nothing -> panic "No diff"
+  where
+    toTOCSummaries' = \case
+      ErrorInfo{..} -> pure $ TOCSummary patch NotSummarizable
+      BranchInfo{..} -> branches >>= toTOCSummaries'
+      LeafInfo{..} -> pure . TOCSummary patch $ case leafCategory of
+        C.Function -> Summarizable leafCategory termName leafSourceSpan (patchType patch)
+        C.Method -> Summarizable leafCategory termName leafSourceSpan (patchType patch)
+        _ -> NotSummarizable
+
+mapToInSummarizable :: DefaultFields fields => Both (Source Char) -> SyntaxDiff leaf fields -> [TOCSummary DiffInfo] -> [TOCSummary DiffInfo]
+mapToInSummarizable sources diff children = case (beforeTerm diff, afterTerm diff) of
+  (_, Just diff') -> mapToInSummarizable' (Both.snd sources) diff' <$> children
+  (Just diff', _) -> mapToInSummarizable' (Both.fst sources) diff' <$> children
+  (Nothing, Nothing) -> []
+  where
+    mapToInSummarizable' :: DefaultFields fields => Source Char -> SyntaxTerm leaf fields -> TOCSummary DiffInfo -> TOCSummary DiffInfo
+    mapToInSummarizable' source term summary =
+      case (parentInfo summary, summarizable term) of
+        (NotSummarizable, SummarizableTerm _) ->
+          summary { parentInfo = InSummarizable (category (extract term)) (toTermName source term) (Info.sourceSpan (extract term)) }
+        (_, _) -> summary
+
+summarizable :: ComonadCofree (Syntax t) w => w a -> SummarizableTerm (w a)
+summarizable term = go (unwrap term) term
+  where go = \case
+          S.Method{} -> SummarizableTerm
+          S.Function{} -> SummarizableTerm
+          _ -> NotSummarizableTerm
+
+toJSONSummaries :: TOCSummary DiffInfo -> [JSONSummary]
+toJSONSummaries TOCSummary{..} = case afterOrBefore summaryPatch of
+  Just diffInfo -> toJSONSummaries' diffInfo
+  Nothing -> panic "No diff"
+  where
+    toJSONSummaries' = \case
+      ErrorInfo{..} -> pure $ ErrorSummary termName infoSpan
+      BranchInfo{..} -> branches >>= toJSONSummaries'
+      LeafInfo{..} -> case parentInfo of
+        NotSummarizable -> []
+        _ -> pure $ JSONSummary parentInfo
+
+termToDiffInfo :: (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffInfo
+termToDiffInfo blob term = case unwrap term of
+  S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term)
+  S.Fixed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term)
+  S.AnonymousFunction _ _ -> LeafInfo C.AnonymousFunction (toTermName' term) (getField $ extract term)
+  S.Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (category $ extract term)
+  S.ParseError _ -> ErrorInfo (getField $ extract term) (toTermName' term)
+  _ -> toLeafInfo term
+  where toTermName' = toTermName blob
+        termToDiffInfo' = termToDiffInfo blob
+        toLeafInfo term = LeafInfo (category $ extract term) (toTermName' term) (getField $ extract term)
+
+toTermName :: forall leaf fields. DefaultFields fields => Source Char -> SyntaxTerm leaf fields -> Text
+toTermName source term = case unwrap term of
+  S.Function identifier _ _ _ -> toTermName' identifier
+  S.Method identifier _ _ _ -> toTermName' identifier
+  _ -> termNameFromSource term
+  where
+    toTermName' = toTermName source
+    termNameFromSource term = termNameFromRange (range term)
+    termNameFromRange range = toText $ Source.slice range source
+    range = characterRange . extract

src/SemanticDiff.hs

@@ -51,7 +51,8 @@ argumentsParser = info (version <*> helper <*> argumentsP)
       <|> flag R.Split R.JSON (long "json" <> help "output a json diff")
       <|> flag' R.Split (long "split" <> help "output a split diff")
       <|> flag' R.Summary (long "summary" <> help "output a diff summary")
-      <|> flag' R.SExpression (long "sexpression" <> help "output an s-expression diff tree"))
+      <|> flag' R.SExpression (long "sexpression" <> help "output an s-expression diff tree")
+      <|> flag' R.TOC (long "toc" <> help "output a table of contents diff summary"))
       <*> optional (option auto (long "timeout" <> help "timeout for per-file diffs in seconds, defaults to 7 seconds"))
       <*> optional (strOption (long "output" <> short 'o' <> help "output directory for split diffs, defaults to stdout if unspecified"))
       <*> switch (long "no-index" <> help "compare two paths on the filesystem")