diff --git a/semantic-diff.cabal b/semantic-diff.cabal index caaa5ed28..939d98410 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -48,6 +48,7 @@ library , Renderer.Split , Renderer.Summary , Renderer.SExpression + , Renderer.TOC , SemanticDiff , SES , Source diff --git a/src/Diffing.hs b/src/Diffing.hs index 3bc44cf2b..75499390f 100644 --- a/src/Diffing.hs +++ b/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 diff --git a/src/Patch.hs b/src/Patch.hs index da267f947..0e976a91c 100644 --- a/src/Patch.hs +++ b/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 diff --git a/src/Renderer.hs b/src/Renderer.hs index 14aae8bd6..8b72c8490 100644 --- a/src/Renderer.hs +++ b/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 diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs new file mode 100644 index 000000000..de8dbbfc9 --- /dev/null +++ b/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 diff --git a/src/SemanticDiff.hs b/src/SemanticDiff.hs index 0fa9195b2..b4813c268 100644 --- a/src/SemanticDiff.hs +++ b/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")