diff --git a/.gitmodules b/.gitmodules index 7ede936ae..8408b932a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -37,3 +37,6 @@ [submodule "languages/typescript/vendor/tree-sitter-typescript"] path = languages/typescript/vendor/tree-sitter-typescript url = https://github.com/tree-sitter/tree-sitter-typescript/ +[submodule "languages/python/vendor/tree-sitter-python"] + path = languages/python/vendor/tree-sitter-python + url = https://github.com/tree-sitter/tree-sitter-python.git diff --git a/languages/python/Setup.hs b/languages/python/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/languages/python/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/languages/python/python.cabal b/languages/python/python.cabal new file mode 100644 index 000000000..345cea22f --- /dev/null +++ b/languages/python/python.cabal @@ -0,0 +1,26 @@ +name: python +version: 0.1.0 +synopsis: tree-sitter python language bindings +homepage: https://github.com/github/semantic-diff#readme +description: Please see README.md +author: semantic-code +maintainer: tclem@github.com +copyright: 2017 GitHub +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Text.Parser.TreeSitter.Python + build-depends: base >= 4.7 && < 5 + , haskell-tree-sitter + default-language: Haskell2010 + c-sources: vendor/tree-sitter-python/src/parser.c + , vendor/tree-sitter-python/src/scanner.cc + extra-libraries: stdc++ + +source-repository head + type: git + location: https://github.com/github/semantic-diff diff --git a/languages/python/src/Text/Parser/TreeSitter/Python.hs b/languages/python/src/Text/Parser/TreeSitter/Python.hs new file mode 100644 index 000000000..c5d52140b --- /dev/null +++ b/languages/python/src/Text/Parser/TreeSitter/Python.hs @@ -0,0 +1,8 @@ +module Text.Parser.TreeSitter.Python +( tree_sitter_python +) where + +import Foreign.Ptr +import Text.Parser.TreeSitter + +foreign import ccall unsafe "vendor/tree-sitter-python/src/parser.c tree_sitter_python" tree_sitter_python :: Ptr Language diff --git a/languages/python/vendor/tree-sitter-python b/languages/python/vendor/tree-sitter-python new file mode 160000 index 000000000..743cabab8 --- /dev/null +++ b/languages/python/vendor/tree-sitter-python @@ -0,0 +1 @@ +Subproject commit 743cabab8c0b243082e497d2b677a7f703dc5c5d diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 6ba785337..0c418e541 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -51,6 +51,8 @@ library , Language.Ruby.Syntax , Language.TypeScript , Language.TypeScript.Syntax + , Language.Python + , Language.Python.Syntax , Parser , Patch , Paths_semantic_diff @@ -123,6 +125,7 @@ library , ruby , javascript , typescript + , python , network , clock , yaml diff --git a/src/Arguments.hs b/src/Arguments.hs index cf8d3a559..e0a24d79b 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -3,42 +3,57 @@ module Arguments where import Data.Maybe +import Data.Record +import Data.String +import Info import Language -import Prelude import Prologue import Renderer -import Renderer.SExpression -import Info +import Source +import Syntax +import Term +import Text.Show data DiffMode = DiffStdin | DiffCommits String String [(FilePath, Maybe Language)] | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) deriving Show data DiffArguments where - DiffArguments :: (Monoid output, StringConv output ByteString) => - { diffRenderer :: DiffRenderer DefaultFields output + DiffArguments :: (Monoid output, StringConv output ByteString, HasField fields Category, NFData (Record fields)) => + { diffRenderer :: DiffRenderer fields output + , termDecorator :: Source -> Term (Syntax Text) (Record DefaultFields) -> Term (Syntax Text) (Record fields) , diffMode :: DiffMode , gitDir :: FilePath , alternateObjectDirs :: [FilePath] } -> DiffArguments -deriving instance Show DiffArguments +instance Show DiffArguments where + showsPrec d DiffArguments{..} = showParen (d > 10) $ showString "DiffArguments { " . foldr (.) identity (intersperse (showString ", ") fields) . showString " }" + where fields = [ showString "diffRenderer " . shows diffRenderer + , showString "termDecorator _" + , showString "diffMode " . shows diffMode + , showString "gitDir " . shows gitDir + , showString "alternateObjectDirs " . shows alternateObjectDirs ] type DiffArguments' = DiffMode -> FilePath -> [FilePath] -> DiffArguments +-- | The identity decorator, i.e. a decorator which ignores the source and passes terms through unchanged. +identityDecorator :: Source -> Term f a -> Term f a +identityDecorator = const identity + patchDiff :: DiffArguments' -patchDiff = DiffArguments PatchRenderer +patchDiff = DiffArguments PatchRenderer identityDecorator jsonDiff :: DiffArguments' -jsonDiff = DiffArguments JSONDiffRenderer +jsonDiff = DiffArguments JSONDiffRenderer identityDecorator summaryDiff :: DiffArguments' -summaryDiff = DiffArguments SummaryRenderer +summaryDiff = DiffArguments SummaryRenderer identityDecorator sExpressionDiff :: DiffArguments' -sExpressionDiff = DiffArguments (SExpressionDiffRenderer TreeOnly) +sExpressionDiff = DiffArguments (SExpressionDiffRenderer TreeOnly) identityDecorator tocDiff :: DiffArguments' -tocDiff = DiffArguments ToCRenderer +tocDiff = DiffArguments ToCRenderer declarationDecorator data ParseMode = ParseCommit String [(FilePath, Maybe Language)] | ParsePaths [(FilePath, Maybe Language)] diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index d5a7f4147..c15bb1d40 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE DataKinds, GADTs, InstanceSigs, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-} -- | Assignment of AST onto some other structure (typically terms). -- -- Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and SourceSpan). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference. @@ -86,6 +86,7 @@ import qualified Data.IntMap.Lazy as IntMap import Data.Ix (inRange) import Data.List.NonEmpty (nonEmpty) import Data.Record +import GHC.Stack import qualified Info import Prologue hiding (Alt, get, Location, state) import Range (offsetRange) @@ -99,32 +100,32 @@ import Text.Show hiding (show) type Assignment node = Freer (AssignmentF node) data AssignmentF node a where - Location :: AssignmentF node Location - Source :: AssignmentF symbol ByteString - Children :: Assignment symbol a -> AssignmentF symbol a - Choose :: IntMap.IntMap a -> AssignmentF node a - Alt :: a -> a -> AssignmentF symbol a - Empty :: AssignmentF symbol a + Location :: HasCallStack => AssignmentF node Location + Source :: HasCallStack => AssignmentF symbol ByteString + Children :: HasCallStack => Assignment symbol a -> AssignmentF symbol a + Choose :: HasCallStack => IntMap.IntMap a -> AssignmentF node a + Alt :: HasCallStack => a -> a -> AssignmentF symbol a + Empty :: HasCallStack => AssignmentF symbol a -- | Zero-width production of the current location. -- -- If assigning at the end of input or at the end of a list of children, the loccation will be returned as an empty Range and SourceSpan at the current offset. Otherwise, it will be the Range and SourceSpan of the current node. -location :: Assignment (Node grammar) Location +location :: HasCallStack => Assignment (Node grammar) Location location = Location `Then` return --- | Zero-width match of a node with the given symbol. +-- | Zero-width match of a node with the given symbol, producing the current node’s location. -- -- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (symbol A *> b)' is fine, but 'many (symbol A)' is not. -symbol :: (Enum symbol, Eq symbol) => symbol -> Assignment (Node symbol) () -symbol s = Choose (IntMap.singleton (fromEnum s) ()) `Then` return +symbol :: (Enum symbol, Eq symbol, HasCallStack) => symbol -> Assignment (Node symbol) Location +symbol s = withFrozenCallStack $ Choose (IntMap.singleton (fromEnum s) ()) `Then` (const location) -- | A rule to produce a node’s source as a ByteString. -source :: Assignment symbol ByteString -source = Source `Then` return +source :: HasCallStack => Assignment symbol ByteString +source = withFrozenCallStack $ Source `Then` return -- | Match a node by applying an assignment to its children. -children :: Assignment symbol a -> Assignment symbol a -children forEach = Children forEach `Then` return +children :: HasCallStack => Assignment symbol a -> Assignment symbol a +children forEach = withFrozenCallStack $ Children forEach `Then` return -- | A rose tree. @@ -145,17 +146,22 @@ type AST grammar = Rose (Node grammar) data Result symbol a = Result { resultErrors :: [Error symbol], resultValue :: Maybe a } deriving (Eq, Foldable, Functor, Traversable) -data Error symbol = Error - { errorPos :: Info.SourcePos - , errorExpected :: [symbol] - , errorActual :: Maybe symbol - } - deriving (Eq, Show) +data Error symbol where + Error + :: HasCallStack + => { errorPos :: Info.SourcePos + , errorExpected :: [symbol] + , errorActual :: Maybe symbol + } -> Error symbol + +deriving instance Eq symbol => Eq (Error symbol) +deriving instance Show symbol => Show (Error symbol) -- | Pretty-print an Error with reference to the source where it occurred. showError :: Show symbol => Source.Source -> Error symbol -> ShowS showError source Error{..} = showSourcePos errorPos . showString ": error: " . showExpectation . showChar '\n' + . showString (prettyCallStack callStack) . showChar '\n' . showString context -- actualLines results include line endings, so no newline here . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') . showChar '^' . showChar '\n' where showExpectation = case (errorExpected, errorActual) of @@ -177,10 +183,10 @@ showSourcePos :: Info.SourcePos -> ShowS showSourcePos Info.SourcePos{..} = shows line . showChar ':' . shows column -- | Run an assignment over an AST exhaustively. -assign :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> Source.Source -> AST grammar -> Result grammar a +assign :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar, HasCallStack) => Assignment (Node grammar) a -> Source.Source -> AST grammar -> Result grammar a assign assignment source = fmap snd . assignAllFrom assignment . makeState source . pure -assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) +assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar, HasCallStack) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) assignAllFrom assignment state = case runAssignment assignment state of Result es (Just (state, a)) -> case stateNodes (dropAnonymous state) of [] -> Result [] (Just (state, a)) @@ -188,7 +194,7 @@ assignAllFrom assignment state = case runAssignment assignment state of r -> r -- | Run an assignment of nodes in a grammar onto terms in a syntax. -runAssignment :: forall grammar a. (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) +runAssignment :: forall grammar a. (Symbol grammar, Enum grammar, Eq grammar, Show grammar, HasCallStack) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) runAssignment = iterFreer run . fmap (\ a state -> Result [] (Just (state, a))) where run :: AssignmentF (Node grammar) x -> (x -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a)) -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) run assignment yield initialState = case (assignment, stateNodes) of @@ -236,7 +242,9 @@ makeState source nodes = AssignmentState 0 (Info.SourcePos 1 1) source nodes -- Instances instance Enum symbol => Alternative (Assignment (Node symbol)) where + empty :: HasCallStack => Assignment (Node symbol) a empty = Empty `Then` return + (<|>) :: HasCallStack => Assignment (Node symbol) a -> Assignment (Node symbol) a -> Assignment (Node symbol) a a <|> b = case (a, b) of (_, Empty `Then` _) -> a (Empty `Then` _, _) -> b diff --git a/src/Diff.hs b/src/Diff.hs index 34d3881c2..e90011c17 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Diff where @@ -24,10 +24,9 @@ diffCost :: (Foldable f, Functor f) => Diff f annotation -> Int diffCost = diffSum $ patchSum termSize -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. -mergeMaybe :: forall f annotation. Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation) +mergeMaybe :: Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation) mergeMaybe transform extractAnnotation = iter algebra . fmap transform - where algebra :: TermF f (Both annotation) (Maybe (Term f annotation)) -> Maybe (Term f annotation) - algebra (annotations :< syntax) = cofree . (extractAnnotation annotations :<) <$> sequenceAlt syntax + where algebra (annotations :< syntax) = cofree . (extractAnnotation annotations :<) <$> sequenceAlt syntax -- | Recover the before state of a diff. beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation) @@ -44,13 +43,8 @@ mapAnnotations :: (Functor f, Functor g) => (annotation -> annotation') -> Free (TermF f (g annotation)) (Patch (Term f annotation)) -> Free (TermF f (g annotation')) (Patch (Term f annotation')) -mapAnnotations f = iter (\ (h :< functor) -> wrap (fmap f h :< functor)) . fmap (pure . fmap (fmap f)) +mapAnnotations f = hoistFree (first (fmap f)) . fmap (fmap (fmap f)) --- | Map a function over the annotations of a single diff node, if it is in Free. -modifyAnnotations :: (Functor f, Functor g) => (annotation -> annotation) -> Free (TermF f (g annotation)) a -> Free (TermF f (g annotation)) a -modifyAnnotations f r = case runFree r of - Free (ga :< functor) -> wrap (fmap f ga :< functor) - _ -> r instance (NFData (f (Diff f a)), NFData (Cofree f a), NFData a, Functor f) => NFData (Diff f a) where rnf fa = case runFree fa of diff --git a/src/Interpreter.hs b/src/Interpreter.hs index e86a8ab00..3fadfe218 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -17,11 +17,17 @@ import Syntax as S hiding (Return) import Term -- | Diff two terms recursively, given functions characterizing the diffing. -diffTerms :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector)) +diffTerms :: (Eq leaf, Hashable leaf, HasField fields Category) => SyntaxTerm leaf fields -- ^ A term representing the old state. -> SyntaxTerm leaf fields -- ^ A term representing the new state. -> SyntaxDiff leaf fields -diffTerms = (runAlgorithm (decomposeWith algorithmWithTerms) .) . diff +diffTerms a b = stripDiff (runAlgorithm (decomposeWith algorithmWithTerms) ((diff `on` defaultFeatureVectorDecorator getLabel) a b)) + +-- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram. +getLabel :: HasField fields Category => TermF (Syntax leaf) (Record fields) a -> (Category, Maybe leaf) +getLabel (h :< t) = (Info.category h, case t of + Leaf s -> Just s + _ -> Nothing) -- | Run an Algorithm to completion by repeated application of a stepping operation and return its result. runAlgorithm :: forall f result diff --git a/src/Language/Python.hs b/src/Language/Python.hs new file mode 100644 index 000000000..31890baf5 --- /dev/null +++ b/src/Language/Python.hs @@ -0,0 +1 @@ +module Language.Python where diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs new file mode 100644 index 000000000..56115fc1d --- /dev/null +++ b/src/Language/Python/Syntax.hs @@ -0,0 +1 @@ +module Language.Python.Syntax where diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 20eb0b0a5..c64f4e152 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -11,8 +11,9 @@ import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement +import GHC.Stack import Language.Haskell.TH hiding (location, Range(..)) -import Prologue hiding (for, get, Location, optional, state, unless) +import Prologue hiding (for, get, Location, state, unless) import Term import Text.Parser.TreeSitter.Language import Text.Parser.TreeSitter.Ruby @@ -54,27 +55,30 @@ mkSymbolDatatype (mkName "Grammar") tree_sitter_ruby -- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax. -assignment :: Assignment (Node Grammar) [Term Syntax Location] +assignment :: HasCallStack => Assignment (Node Grammar) [Term Syntax Location] assignment = symbol Program *> children (many declaration) -declaration :: Assignment (Node Grammar) (Term Syntax Location) +declaration :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) declaration = comment <|> class' <|> method -class' :: Assignment (Node Grammar) (Term Syntax Location) -class' = symbol Class *> term <*> children (Declaration.Class <$> (constant <|> scopeResolution) <*> (superclass <|> pure []) <*> many declaration) +class' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +class' = makeTerm <$> symbol Class <*> children (Declaration.Class <$> (constant <|> scopeResolution) <*> (superclass <|> pure []) <*> many declaration) where superclass = pure <$ symbol Superclass <*> children constant scopeResolution = symbol ScopeResolution *> children (constant <|> identifier) -constant :: Assignment (Node Grammar) (Term Syntax Location) -constant = leaf Constant Syntax.Identifier +constant :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +constant = makeTerm <$> symbol Constant <*> (Syntax.Identifier <$> source) -identifier :: Assignment (Node Grammar) (Term Syntax Location) -identifier = leaf Identifier Syntax.Identifier +identifier :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +identifier = makeTerm <$> symbol Identifier <*> (Syntax.Identifier <$> source) -method :: Assignment (Node Grammar) (Term Syntax Location) -method = symbol Method *> term <*> children (Declaration.Method <$> identifier <*> pure [] <*> (term <*> many statement)) +method :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +method = makeTerm <$> symbol Method <*> children (Declaration.Method <$> identifier <*> pure [] <*> statements) -statement :: Assignment (Node Grammar) (Term Syntax Location) +statements :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +statements = makeTerm <$> location <*> many statement + +statement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) statement = exit Statement.Return Return <|> exit Statement.Yield Yield <|> exit Statement.Break Break @@ -86,71 +90,70 @@ statement = exit Statement.Return Return <|> for <|> literal <|> assignment' - where exit construct sym = symbol sym *> term <*> children (construct <$> optional (symbol ArgumentList *> children statement)) + where exit construct sym = makeTerm <$> symbol sym <*> children ((construct .) . fromMaybe <$> emptyTerm <*> optional (symbol ArgumentList *> children statement)) -lvalue :: Assignment (Node Grammar) (Term Syntax Location) +lvalue :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) lvalue = identifier -expression :: Assignment (Node Grammar) (Term Syntax Location) +expression :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) expression = identifier <|> statement -comment :: Assignment (Node Grammar) (Term Syntax Location) -comment = leaf Comment Comment.Comment +comment :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -if' :: Assignment (Node Grammar) (Term Syntax Location) +if' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) if' = ifElsif If - <|> symbol IfModifier *> term <*> children (flip Statement.If <$> statement <*> statement <*> (term <*> pure Syntax.Empty)) - where ifElsif s = symbol s *> term <*> children (Statement.If <$> statement <*> (term <*> many statement) <*> optional (ifElsif Elsif <|> symbol Else *> term <*> children (many statement))) + <|> makeTerm <$> symbol IfModifier <*> children (flip Statement.If <$> statement <*> statement <*> (makeTerm <$> location <*> pure Syntax.Empty)) + where ifElsif s = makeTerm <$> symbol s <*> children (Statement.If <$> statement <*> statements <*> (fromMaybe <$> emptyTerm <*> optional (ifElsif Elsif <|> makeTerm <$> symbol Else <*> children (many statement)))) -unless :: Assignment (Node Grammar) (Term Syntax Location) -unless = symbol Unless *> term <*> children (Statement.If <$> (term <*> (Expression.Not <$> statement)) <*> (term <*> many statement) <*> optional (symbol Else *> term <*> children (many statement))) - <|> symbol UnlessModifier *> term <*> children (flip Statement.If <$> statement <*> (term <*> (Expression.Not <$> statement)) <*> (term <*> pure Syntax.Empty)) +unless :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +unless = makeTerm <$> symbol Unless <*> children (Statement.If <$> invert statement <*> statements <*> (fromMaybe <$> emptyTerm <*> optional (makeTerm <$> symbol Else <*> children (many statement)))) + <|> makeTerm <$> symbol UnlessModifier <*> children (flip Statement.If <$> statement <*> invert statement <*> (makeTerm <$> location <*> pure Syntax.Empty)) -while :: Assignment (Node Grammar) (Term Syntax Location) -while = symbol While *> term <*> children (Statement.While <$> statement <*> (term <*> many statement)) - <|> symbol WhileModifier *> term <*> children (flip Statement.While <$> statement <*> statement) +while :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +while = makeTerm <$> symbol While <*> children (Statement.While <$> statement <*> statements) + <|> makeTerm <$> symbol WhileModifier <*> children (flip Statement.While <$> statement <*> statement) -until :: Assignment (Node Grammar) (Term Syntax Location) -until = symbol Until *> term <*> children (Statement.While <$> (term <*> (Expression.Not <$> statement)) <*> (term <*> many statement)) - <|> symbol UntilModifier *> term <*> children (flip Statement.While <$> statement <*> (term <*> (Expression.Not <$> statement))) +until :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +until = makeTerm <$> symbol Until <*> children (Statement.While <$> invert statement <*> statements) + <|> makeTerm <$> symbol UntilModifier <*> children (flip Statement.While <$> statement <*> invert statement) -for :: Assignment (Node Grammar) (Term Syntax Location) -for = symbol For *> term <*> children (Statement.ForEach <$> identifier <*> statement <*> (term <*> many statement)) +for :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +for = makeTerm <$> symbol For <*> children (Statement.ForEach <$> identifier <*> statement <*> statements) -assignment' :: Assignment (Node Grammar) (Term Syntax Location) +assignment' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) assignment' - = symbol Assignment *> term <*> children (Statement.Assignment <$> lvalue <*> expression) - <|> symbol OperatorAssignment *> term <*> children (lvalue >>= \ var -> Statement.Assignment var <$> - (symbol AnonPlusEqual *> term <*> (Expression.Plus var <$> expression) - <|> symbol AnonMinusEqual *> term <*> (Expression.Minus var <$> expression) - <|> symbol AnonStarEqual *> term <*> (Expression.Times var <$> expression) - <|> symbol AnonStarStarEqual *> term <*> (Expression.Power var <$> expression) - <|> symbol AnonSlashEqual *> term <*> (Expression.DividedBy var <$> expression) - <|> symbol AnonPipePipeEqual *> term <*> (Expression.And var <$> expression) - <|> symbol AnonPipeEqual *> term <*> (Expression.BOr var <$> expression) - <|> symbol AnonAmpersandAmpersandEqual *> term <*> (Expression.And var <$> expression) - <|> symbol AnonAmpersandEqual *> term <*> (Expression.BAnd var <$> expression) - <|> symbol AnonPercentEqual *> term <*> (Expression.Modulo var <$> expression) - <|> symbol AnonRAngleRAngleEqual *> term <*> (Expression.RShift var <$> expression) - <|> symbol AnonLAngleLAngleEqual *> term <*> (Expression.LShift var <$> expression) - <|> symbol AnonCaretEqual *> term <*> (Expression.BXOr var <$> expression))) + = makeTerm <$> symbol Assignment <*> children (Statement.Assignment <$> lvalue <*> expression) + <|> makeTerm <$> symbol OperatorAssignment <*> children (lvalue >>= \ var -> Statement.Assignment var <$> + (makeTerm <$> symbol AnonPlusEqual <*> (Expression.Plus var <$> expression) + <|> makeTerm <$> symbol AnonMinusEqual <*> (Expression.Minus var <$> expression) + <|> makeTerm <$> symbol AnonStarEqual <*> (Expression.Times var <$> expression) + <|> makeTerm <$> symbol AnonStarStarEqual <*> (Expression.Power var <$> expression) + <|> makeTerm <$> symbol AnonSlashEqual <*> (Expression.DividedBy var <$> expression) + <|> makeTerm <$> symbol AnonPipePipeEqual <*> (Expression.And var <$> expression) + <|> makeTerm <$> symbol AnonPipeEqual <*> (Expression.BOr var <$> expression) + <|> makeTerm <$> symbol AnonAmpersandAmpersandEqual <*> (Expression.And var <$> expression) + <|> makeTerm <$> symbol AnonAmpersandEqual <*> (Expression.BAnd var <$> expression) + <|> makeTerm <$> symbol AnonPercentEqual <*> (Expression.Modulo var <$> expression) + <|> makeTerm <$> symbol AnonRAngleRAngleEqual <*> (Expression.RShift var <$> expression) + <|> makeTerm <$> symbol AnonLAngleLAngleEqual <*> (Expression.LShift var <$> expression) + <|> makeTerm <$> symbol AnonCaretEqual <*> (Expression.BXOr var <$> expression))) -literal :: Assignment (Node Grammar) (Term Syntax Location) -literal = leaf Language.Ruby.Syntax.True (const Literal.true) - <|> leaf Language.Ruby.Syntax.False (const Literal.false) - <|> leaf Language.Ruby.Syntax.Integer Literal.Integer - <|> leaf Symbol Literal.Symbol - <|> symbol Range *> term <*> children (Literal.Range <$> statement <*> statement) -- FIXME: represent the difference between .. and ... +literal :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +literal = makeTerm <$> symbol Language.Ruby.Syntax.True <*> (Literal.true <$ source) + <|> makeTerm <$> symbol Language.Ruby.Syntax.False <*> (Literal.false <$ source) + <|> makeTerm <$> symbol Language.Ruby.Syntax.Integer <*> (Literal.Integer <$> source) + <|> makeTerm <$> symbol Symbol <*> (Literal.Symbol <$> source) + <|> makeTerm <$> symbol Range <*> children (Literal.Range <$> statement <*> statement) -- FIXME: represent the difference between .. and ... --- | Assignment of the current node’s annotation. -term :: InUnion Syntax' f => Assignment (Node grammar) (f (Term Syntax Location) -> Term Syntax Location) -term = (\ a f -> cofree $ a :< inj f) <$> location +invert :: (InUnion fs Expression.Boolean, HasCallStack) => Assignment (Node grammar) (Term (Union fs) Location) -> Assignment (Node grammar) (Term (Union fs) Location) +invert term = makeTerm <$> location <*> fmap Expression.Not term -leaf :: (Enum symbol, Eq symbol, InUnion Syntax' f) => symbol -> (ByteString -> f (Term Syntax Location)) -> Assignment (Node symbol) (Term Syntax Location) -leaf s f = (\ a -> cofree . (a :<) . inj . f) <$ symbol s <*> location <*> source +makeTerm :: (InUnion fs f, HasCallStack) => a -> f (Term (Union fs) a) -> (Term (Union fs) a) +makeTerm a f = cofree $ a :< inj f -optional :: Assignment (Node Grammar) (Term Syntax Location) -> Assignment (Node Grammar) (Term Syntax Location) -optional a = a <|> term <*> pure Syntax.Empty +emptyTerm :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) +emptyTerm = makeTerm <$> location <*> pure Syntax.Empty -- | An F-algebra on some carrier functor 'f'. diff --git a/src/Patch.hs b/src/Patch.hs index 8f42e1ee6..f7b960cfe 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -7,15 +7,14 @@ module Patch , deleting , after , before -, afterOrBefore , unPatch , patchSum , maybeFst , maybeSnd , mapPatch -, patchType ) where +import Data.Align import Data.Functor.Listable import Data.These import Prologue @@ -51,12 +50,6 @@ 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 @@ -80,11 +73,6 @@ 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 patch = case patch of - Replace{} -> "modified" - Insert{} -> "added" - Delete{} -> "removed" -- Instances @@ -93,3 +81,8 @@ instance Listable1 Patch where instance Listable a => Listable (Patch a) where tiers = tiers1 + +instance Crosswalk Patch where + crosswalk f (Replace a b) = alignWith (these Delete Insert Replace) (f a) (f b) + crosswalk f (Insert b) = Insert <$> f b + crosswalk f (Delete a) = Delete <$> f a diff --git a/src/Renderer.hs b/src/Renderer.hs index 05082cafc..af96ef0ee 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE GADTs, MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators #-} module Renderer ( DiffRenderer(..) +, SExpressionFormat(..) , resolveDiffRenderer , runDiffRenderer +, declarationDecorator , ParseTreeRenderer(..) , resolveParseTreeRenderer , runParseTreeRenderer @@ -25,7 +27,7 @@ import Renderer.Patch as R import Renderer.SExpression as R import Renderer.Summary as R import Renderer.TOC as R -import Source (SourceBlob(..)) +import Source (SourceBlob(..), Source) import Syntax as S import Term @@ -35,7 +37,7 @@ data DiffRenderer fields output where JSONDiffRenderer :: (ToJSONFields (Record fields), HasField fields Range) => DiffRenderer fields (Map Text Value) SummaryRenderer :: HasDefaultFields fields => DiffRenderer fields Summaries SExpressionDiffRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> DiffRenderer fields ByteString - ToCRenderer :: HasDefaultFields fields => DiffRenderer fields Summaries + ToCRenderer :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => DiffRenderer fields Summaries resolveDiffRenderer :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> (Both SourceBlob -> Diff (Syntax Text) (Record fields) -> output) resolveDiffRenderer renderer = case renderer of @@ -49,6 +51,10 @@ runDiffRenderer :: (Monoid output, StringConv output ByteString) => DiffRenderer runDiffRenderer = foldMap . uncurry . resolveDiffRenderer +declarationDecorator :: Source -> Term (Syntax Text) (Record DefaultFields) -> Term (Syntax Text) (Record (Maybe Declaration ': DefaultFields)) +declarationDecorator = decoratorWithAlgebra . declarationAlgebra + + data ParseTreeRenderer fields output where SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> ParseTreeRenderer fields ByteString JSONParseTreeRenderer :: (ToJSONFields (Record fields), HasField fields Range) => ParseTreeRenderer fields [Value] diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index a4583f1e9..19e66f51b 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -1,196 +1,161 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Renderer.TOC (toc, diffTOC, JSONSummary(..), Summarizable(..), isErrorSummary) where +{-# LANGUAGE DeriveAnyClass, RankNTypes #-} +module Renderer.TOC +( toc +, diffTOC +, JSONSummary(..) +, Summarizable(..) +, isValidSummary +, Declaration(..) +, declaration +, declarationAlgebra +, Entry(..) +, tableOfContentsBy +, dedupe +, entrySummary +) where import Category as C import Data.Aeson +import Data.Align (crosswalk) import Data.Functor.Both hiding (fst, snd) import qualified Data.Functor.Both as Both +import Data.Functor.Listable import Data.Text (toLower) +import Data.Text.Listable +import Data.These import Data.Record import Diff import Info +import Patch import Prologue -import Range import Renderer.Summary (Summaries(..)) import qualified Data.List as List import qualified Data.Map as Map hiding (null) import Source hiding (null) import Syntax as S import Term -import Patch 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" .= toCategoryName parentCategory, "term" .= parentTermName, "span" .= parentSourceSpan ] - Summarizable{..} -> [ "changeType" .= summarizableChangeType, "category" .= toCategoryName summarizableCategory, "term" .= summarizableTermName, "span" .= summarizableSourceSpan ] - NotSummarizable -> panic "NotSummarizable should have been pruned" + toJSON (JSONSummary Summarizable{..}) = object [ "changeType" .= summarizableChangeType, "category" .= toCategoryName summarizableCategory, "term" .= summarizableTermName, "span" .= summarizableSourceSpan ] toJSON ErrorSummary{..} = object [ "error" .= error, "span" .= errorSpan ] -isErrorSummary :: JSONSummary -> Bool -isErrorSummary ErrorSummary{} = True -isErrorSummary _ = False +isValidSummary :: JSONSummary -> Bool +isValidSummary ErrorSummary{} = False +isValidSummary _ = True -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 +data Summarizable + = Summarizable + { summarizableCategory :: Category + , summarizableTermName :: Text + , summarizableSourceSpan :: SourceSpan + , summarizableChangeType :: Text + } deriving (Eq, Show) -data SummarizableTerm a = SummarizableTerm a | NotSummarizableTerm a +-- | A declaration’s identifier and type. +data Declaration + = MethodDeclaration { declarationIdentifier :: Text } + | FunctionDeclaration { declarationIdentifier :: Text } + | ErrorDeclaration { declarationIdentifier :: Text } + deriving (Eq, Generic, NFData, Show) -toc :: HasDefaultFields fields => Both SourceBlob -> Diff (Syntax Text) (Record fields) -> Summaries -toc blobs diff = Summaries changes 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 +-- | Produce the annotations of nodes representing declarations. +declaration :: (HasField fields (Maybe Declaration), HasField fields Category) => TermF (Syntax Text) (Record fields) a -> Maybe (Record fields) +declaration (annotation :< syntax) + | S.ParseError{} <- syntax = Just (setCategory annotation C.ParseError) + | otherwise = annotation <$ (getField annotation :: Maybe Declaration) - -- Returns a key representing the filename. If the filenames are different, - -- return 'before -> after'. - toSummaryKey :: Both FilePath -> Text - toSummaryKey = runBothWith $ \before after -> - toS $ case (before, after) of - ("", after) -> after - (before, "") -> before - (before, after) | before == after -> after - (before, after) | not (null before) && not (null after) -> before <> " -> " <> after - (_, _) -> mempty -diffTOC :: (StringConv leaf Text, HasDefaultFields fields) => Both SourceBlob -> SyntaxDiff leaf fields -> [JSONSummary] -diffTOC blobs diff = removeDupes (diffToTOCSummaries (source <$> blobs) diff) >>= toJSONSummaries - where - removeDupes :: [TOCSummary DiffInfo] -> [TOCSummary DiffInfo] - removeDupes = foldl' go [] - where - go xs x | (_, _ : _) <- find exactMatch x xs = xs - | (front, existingItem : back) <- find similarMatch x xs = - let - (Summarizable category name sourceSpan _) = parentInfo existingItem - replacement = x { parentInfo = Summarizable category name sourceSpan "modified" } - in - front <> (replacement : back) +-- | Compute 'Declaration's for methods and functions. +declarationAlgebra :: HasField fields Range => Source -> TermF (Syntax Text) (Record fields) (Term (Syntax Text) (Record fields), Maybe Declaration) -> Maybe Declaration +declarationAlgebra source r = case tailF r of + S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) + S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) + S.Method _ (identifier, _) (Just (receiver, _)) _ _ + | S.Indexed [receiverParams] <- unwrap receiver + , S.ParameterDecl (Just ty) _ <- unwrap receiverParams -> Just $ MethodDeclaration ("(" <> getSource ty <> ") " <> getSource identifier) + | otherwise -> Just $ MethodDeclaration (getSource receiver <> "." <> getSource identifier) + S.ParseError{} -> Just $ ErrorDeclaration (toText (Source.slice (byteRange (headF r)) source)) + _ -> Nothing + where getSource = toText . flip Source.slice source . byteRange . extract + + +-- | An entry in a table of contents. +data Entry a + = Unchanged { entryPayload :: a } -- ^ An entry for an unchanged portion of a diff (i.e. a diff node not containing any patches). + | 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 :: Traversable f + => (forall b. TermF f annotation b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. + -> Diff f annotation -- ^ The diff to compute the table of contents for. + -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. +tableOfContentsBy selector = fromMaybe [] . iter diffAlgebra . fmap (Just . fmap patchEntry . crosswalk (cata termAlgebra)) + where diffAlgebra r = case (selector (first Both.snd r), fold r) of + (Just a, Nothing) -> Just [Unchanged a] + (Just a, Just []) -> Just [Changed a] + (_ , entries) -> entries + termAlgebra r | Just a <- selector r = [a] + | otherwise = fold r + patchEntry = these Deleted Inserted (const Replaced) . unPatch + +dedupe :: (HasField fields Category, HasField fields (Maybe Declaration)) => [Entry (Record fields)] -> [Entry (Record fields)] +dedupe = foldl' go [] + where go xs x | (_, _:_) <- find (exactMatch `on` entryPayload) x xs = xs + | (front, similar : back) <- find (similarMatch `on` entryPayload) x xs = + front <> (Replaced (entryPayload similar) : back) | otherwise = xs <> [x] + find p x = List.break (p x) - exactMatch a b = parentInfo a == parentInfo b - similarMatch a b = case (parentInfo a, parentInfo b) of - (Summarizable catA nameA _ _, Summarizable catB nameB _ _) -> catA == catB && toLower nameA == toLower nameB - (_, _) -> False + exactMatch = (==) `on` getDeclaration + similarMatch a b = sameCategory a b && similarDeclaration a b + sameCategory = (==) `on` category + similarDeclaration = (==) `on` fmap (toLower . declarationIdentifier) . getDeclaration + getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration + getDeclaration = getField - diffToTOCSummaries :: (StringConv leaf Text, HasDefaultFields fields) => Both Source -> 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) +-- | Construct a 'JSONSummary' from an 'Entry'. Returns 'Nothing' for 'Unchanged' patches. +entrySummary :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => Entry (Record fields) -> Maybe JSONSummary +entrySummary entry = case entry of + Unchanged _ -> Nothing + Changed a -> Just (recordSummary a "modified") + Deleted a -> Just (recordSummary a "removed") + Inserted a -> Just (recordSummary a "added") + Replaced a -> Just (recordSummary a "modified") + where recordSummary record + | C.ParseError <- category record = const (ErrorSummary (maybe "" declarationIdentifier (getField record :: Maybe Declaration)) (sourceSpan record)) + | otherwise = JSONSummary . Summarizable (category record) (maybe "" declarationIdentifier (getField record :: Maybe Declaration)) (sourceSpan record) --- Mark which leaves are summarizable. -toTOCSummaries :: Patch DiffInfo -> [TOCSummary DiffInfo] -toTOCSummaries patch = case afterOrBefore patch of - Just diffInfo -> toTOCSummaries' patch diffInfo - Nothing -> panic "No diff" - where - toTOCSummaries' patch' diffInfo = case diffInfo of - ErrorInfo{..} -> pure $ TOCSummary patch' NotSummarizable - BranchInfo{..} -> join $ zipWith toTOCSummaries' (flattenPatch patch') branches - LeafInfo{..} -> pure . TOCSummary patch' $ case leafCategory of - C.Function -> Summarizable leafCategory termName leafSourceSpan (patchType patch') - C.Method -> Summarizable leafCategory termName leafSourceSpan (patchType patch') - C.SingletonMethod -> Summarizable leafCategory termName leafSourceSpan (patchType patch') - _ -> NotSummarizable +toc :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => Both SourceBlob -> Diff (Syntax Text) (Record fields) -> Summaries +toc blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC + where toMap [] = mempty + toMap as = Map.singleton summaryKey (toJSON <$> as) + summaryKey = toS $ case runJoin (path <$> blobs) of + (before, after) | null before -> after + | null after -> before + | before == after -> after + | otherwise -> before <> " -> " <> after -flattenPatch :: Patch DiffInfo -> [Patch DiffInfo] -flattenPatch patch = case patch of - Replace i1 i2 -> zipWith Replace (toLeafInfos' i1) (toLeafInfos' i2) - Insert info -> Insert <$> toLeafInfos' info - Delete info -> Delete <$> toLeafInfos' info - -toLeafInfos' :: DiffInfo -> [DiffInfo] -toLeafInfos' BranchInfo{..} = branches >>= toLeafInfos' -toLeafInfos' leaf = [leaf] - -mapToInSummarizable :: forall leaf fields. HasDefaultFields fields => Both Source -> 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' :: Source -> 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 0 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 syntax = case syntax of - 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' diffInfo = case diffInfo of - ErrorInfo{..} -> pure $ ErrorSummary termName infoSpan - BranchInfo{..} -> branches >>= toJSONSummaries' - LeafInfo{..} -> case parentInfo of - NotSummarizable -> [] - _ -> pure $ JSONSummary parentInfo - -termToDiffInfo :: forall leaf fields. (StringConv leaf Text, HasDefaultFields fields) => Source -> SyntaxTerm leaf fields -> DiffInfo -termToDiffInfo source 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 0 source - termToDiffInfo' = termToDiffInfo source - toLeafInfo term = LeafInfo (category $ extract term) (toTermName' term) (getField $ extract term) - -toTermName :: forall leaf fields. HasDefaultFields fields => Int -> Source -> SyntaxTerm leaf fields -> Text -toTermName parentOffset parentSource term = case unwrap term of - S.Function identifier _ _ -> toTermName' identifier - S.Method _ identifier Nothing _ _ -> toTermName' identifier - S.Method _ identifier (Just receiver) _ _ -> case unwrap receiver of - S.Indexed [receiverParams] -> case unwrap receiverParams of - S.ParameterDecl (Just ty) _ -> "(" <> toTermName' ty <> ") " <> toTermName' identifier - _ -> toMethodNameWithReceiver receiver identifier - _ -> toMethodNameWithReceiver receiver identifier - _ -> toText source - where - source = Source.slice (offsetRange (range term) (negate parentOffset)) parentSource - toMethodNameWithReceiver receiver name = toTermName' receiver <> "." <> toTermName' name - offset = start (range term) - toTermName' :: SyntaxTerm leaf fields -> Text - toTermName' = toTermName offset source - range = byteRange . extract +diffTOC :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => Diff (Syntax Text) (Record fields) -> [JSONSummary] +diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration -- The user-facing category name toCategoryName :: Category -> Text toCategoryName category = case category of C.SingletonMethod -> "Method" c -> show c + +instance Listable Declaration where + tiers + = cons1 (MethodDeclaration . unListableText) + \/ cons1 (FunctionDeclaration . unListableText) + \/ cons1 (ErrorDeclaration . unListableText) diff --git a/src/Semantic.hs b/src/Semantic.hs index 14e65e0f7..d59f027f3 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -11,7 +11,6 @@ import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import qualified Data.Text as T import Data.Functor.Both -import RWS import Data.Record import Diff import Info @@ -42,32 +41,27 @@ import TreeSitter -- - Easy to consume this interface from other application (e.g a cmdline or web server app). -- | Diff a list of SourceBlob pairs to produce ByteString output using the specified renderer. -diffBlobPairs :: (Monoid output, StringConv output ByteString) => DiffRenderer DefaultFields output -> [Both SourceBlob] -> IO ByteString -diffBlobPairs renderer blobs = do +diffBlobPairs :: (Monoid output, StringConv output ByteString, HasField fields Category, NFData (Record fields)) => (Source -> Term (Syntax Text) (Record DefaultFields) -> Term (Syntax Text) (Record fields)) -> DiffRenderer fields output -> [Both SourceBlob] -> IO ByteString +diffBlobPairs decorator renderer blobs = do diffs <- Async.mapConcurrently go blobs let diffs' = diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff toS <$> renderConcurrently (resolveDiffRenderer renderer) (diffs' `using` parTraversable (parTuple2 r0 rdeepseq)) where go blobPair = do - diff <- diffBlobPair blobPair + diff <- diffBlobPair decorator blobPair pure (blobPair, diff) -- | Diff a pair of SourceBlobs. -diffBlobPair :: Both SourceBlob -> IO (Maybe (Diff (Syntax Text) (Record DefaultFields))) -diffBlobPair blobs = do +diffBlobPair :: (HasField fields Category, NFData (Record fields)) => (Source -> Term (Syntax Text) (Record DefaultFields) -> Term (Syntax Text) (Record fields)) -> Both SourceBlob -> IO (Maybe (Diff (Syntax Text) (Record fields))) +diffBlobPair decorator blobs = do terms <- Async.mapConcurrently parseBlob blobs - pure $ case (runJoin blobs, runJoin terms) of + pure $ case (runJoin blobs, runJoin (decorator . source <$> blobs <*> terms)) of ((left, right), (a, b)) | nonExistentBlob left && nonExistentBlob right -> Nothing | nonExistentBlob right -> Just . pure $ Delete a | nonExistentBlob left -> Just . pure $ Insert b - | otherwise -> Just $ runDiff terms + | otherwise -> Just $ runDiff (both a b) where - runDiff terms = stripDiff (runBothWith diffTerms (fmap decorate (terms `using` parTraversable rdeepseq))) - decorate = defaultFeatureVectorDecorator getLabel - getLabel :: HasField fields Category => TermF (Syntax Text) (Record fields) a -> (Category, Maybe Text) - getLabel (h :< t) = (Info.category h, case t of - Leaf s -> Just s - _ -> Nothing) + runDiff terms = runBothWith diffTerms (terms `using` parTraversable rdeepseq) -- | Parse a list of SourceBlobs and use the specified renderer to produce ByteString output. parseBlobs :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer DefaultFields output -> [SourceBlob] -> IO ByteString diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 331bc82b2..dc3ded441 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -51,7 +51,7 @@ runDiff DiffArguments{..} = do DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b) DiffCommits sha1 sha2 paths -> readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2) DiffStdin -> readStdin - Semantic.diffBlobPairs diffRenderer blobs + Semantic.diffBlobPairs termDecorator diffRenderer blobs runParse :: ParseArguments -> IO ByteString runParse ParseArguments{..} = do diff --git a/test/CommandSpec.hs b/test/CommandSpec.hs index 4f1069db8..b993db6e4 100644 --- a/test/CommandSpec.hs +++ b/test/CommandSpec.hs @@ -6,8 +6,9 @@ import Data.Aeson.Types hiding (parse) import Data.Functor.Both as Both import Data.Map import Data.Maybe +import Data.Record import Data.String -import Info (DefaultFields) +import Info (DefaultFields, HasDefaultFields) import Language import Prologue hiding (readFile, toList) import qualified Data.Vector as V @@ -15,6 +16,7 @@ import qualified Git.Types as Git import Renderer hiding (errors) import Source import Semantic +import Term import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty @@ -54,26 +56,26 @@ spec = parallel $ do describe "fetchDiffs" $ do it "generates diff summaries for two shas" $ do - (errors, summaries) <- fetchDiffsOutput summaryText "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] Renderer.SummaryRenderer + (errors, summaries) <- fetchDiffsOutput summaryText "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] (const identity) Renderer.SummaryRenderer errors `shouldBe` Just (fromList []) summaries `shouldBe` Just (fromList [("methods.rb", ["Added the 'foo()' method"])]) it "generates toc summaries for two shas" $ do - (errors, summaries) <- fetchDiffsOutput termText "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] Renderer.ToCRenderer + (errors, summaries) <- fetchDiffsOutput termText "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] declarationDecorator Renderer.ToCRenderer errors `shouldBe` Just (fromList []) summaries `shouldBe` Just (fromList [("methods.rb", ["foo"])]) it "generates toc summaries for two shas inferring paths" $ do - (errors, summaries) <- fetchDiffsOutput termText "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [] Renderer.ToCRenderer + (errors, summaries) <- fetchDiffsOutput termText "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [] declarationDecorator Renderer.ToCRenderer errors `shouldBe` Just (fromList []) summaries `shouldBe` Just (fromList [("methods.rb", ["foo"])]) it "errors with bad shas" $ - fetchDiffsOutput summaryText "test/fixtures/git/examples/all-languages.git" "dead" "beef" [("methods.rb", Just Ruby)] Renderer.SummaryRenderer + fetchDiffsOutput summaryText "test/fixtures/git/examples/all-languages.git" "dead" "beef" [("methods.rb", Just Ruby)] (const identity) Renderer.SummaryRenderer `shouldThrow` (== Git.BackendError "Could not lookup dead: Object not found - no match for prefix (dead000000000000000000000000000000000000)") it "errors with bad repo path" $ - fetchDiffsOutput summaryText "test/fixtures/git/examples/not-a-repo.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] Renderer.SummaryRenderer + fetchDiffsOutput summaryText "test/fixtures/git/examples/not-a-repo.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] (const identity) Renderer.SummaryRenderer `shouldThrow` errorCall "Could not open repository \"test/fixtures/git/examples/not-a-repo.git\"" where repoPath = "test/fixtures/git/examples/all-languages.git" @@ -84,10 +86,10 @@ spec = parallel $ do data Fixture = Fixture { shas :: Both String, expectedBlobs :: [Both SourceBlob] } -fetchDiffsOutput :: (Object -> Text) -> FilePath -> String -> String -> [(FilePath, Maybe Language)] -> DiffRenderer DefaultFields Summaries -> IO (Maybe (Map Text Value), Maybe (Map Text [Text])) -fetchDiffsOutput f gitDir sha1 sha2 filePaths renderer = do +fetchDiffsOutput :: (HasDefaultFields fields, NFData (Record fields)) => (Object -> Text) -> FilePath -> String -> String -> [(FilePath, Maybe Language)] -> (Source -> SyntaxTerm Text DefaultFields -> SyntaxTerm Text fields) -> DiffRenderer fields Summaries -> IO (Maybe (Map Text Value), Maybe (Map Text [Text])) +fetchDiffsOutput f gitDir sha1 sha2 filePaths decorator renderer = do blobs <- runCommand $ readFilesAtSHAs gitDir [] filePaths (both sha1 sha2) - results <- Semantic.diffBlobPairs renderer blobs + results <- Semantic.diffBlobPairs decorator renderer blobs let json = fromJust (decode (toS results)) pure (errors json, summaries f json) diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index 46aa6b233..ba94fec43 100644 --- a/test/DiffSpec.hs +++ b/test/DiffSpec.hs @@ -2,15 +2,14 @@ module DiffSpec where import Category -import Data.Bifunctor.Join import Data.Functor.Listable import RWS import Data.String import Diff import Info import Interpreter -import Patch import Prologue +import SpecHelpers import Term import Test.Hspec import Test.Hspec.LeanCheck @@ -35,6 +34,3 @@ spec = parallel $ do prop "recovers the after term" $ \ a b -> let diff = stripDiff $ diffTerms (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in afterTerm diff `shouldBe` Just (unListableF b) - -unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation -unListableDiff diff = hoistFree (first unListableF) $ fmap unListableF <$> unListableF diff diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 1f77a6421..038ea1697 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -2,14 +2,11 @@ module InterpreterSpec where import Category -import Data.Array import Data.Functor.Foldable hiding (Nil) import Data.Functor.Listable -import RWS import Data.Record import Data.String import Diff -import Info import Interpreter import Patch import Prologue @@ -22,22 +19,21 @@ import Test.Hspec.LeanCheck spec :: Spec spec = parallel $ do describe "interpret" $ do - let decorate = defaultFeatureVectorDecorator (category . headF) it "returns a replacement when comparing two unicode equivalent terms" $ let termA = cofree $ (StringLiteral :. Nil) :< Leaf ("t\776" :: String) termB = cofree $ (StringLiteral :. Nil) :< Leaf "\7831" in - stripDiff (diffTerms (decorate termA) (decorate termB)) `shouldBe` replacing termA termB + diffTerms termA termB `shouldBe` replacing termA termB prop "produces correct diffs" $ - \ a b -> let diff = stripDiff $ diffTerms (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in + \ a b -> let diff = diffTerms (unListableF a) (unListableF b :: SyntaxTerm String '[Category]) in (beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b)) prop "constructs zero-cost diffs of equal terms" $ - \ a -> let term = decorate (unListableF a :: SyntaxTerm String '[Category]) + \ a -> let term = (unListableF a :: SyntaxTerm String '[Category]) diff = diffTerms term term in diffCost diff `shouldBe` 0 it "produces unbiased insertions within branches" $ - let term s = decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ])) - root = cofree . ((Just (listArray (0, defaultD) (repeat 0)) :. Program :. Nil) :<) . Indexed in - stripDiff (diffTerms (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` wrap (pure (Program :. Nil) :< Indexed [ inserting (stripTerm (term "a")), cata wrap (fmap pure (stripTerm (term "b"))) ]) + let term s = cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ]) :: SyntaxTerm String '[Category] + root = cofree . ((Program :. Nil) :<) . Indexed in + diffTerms (root [ term "b" ]) (root [ term "a", term "b" ]) `shouldBe` wrap (pure (Program :. Nil) :< Indexed [ inserting (term "a"), cata wrap (fmap pure (term "b")) ]) diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs index a0a7f34fc..32030b66e 100644 --- a/test/SemanticSpec.hs +++ b/test/SemanticSpec.hs @@ -7,7 +7,6 @@ import Test.Hspec.Expectations.Pretty import Language import Syntax import Renderer -import Renderer.SExpression import Source spec :: Spec diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index a10649ed0..aefe3ed73 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -4,25 +4,29 @@ module SpecHelpers , parseFilePath , readFile , languageForFilePath +, unListableDiff ) where -import Data.Functor.Both -import Language -import Prologue hiding (readFile) import qualified Data.ByteString as B +import Data.Functor.Both +import Data.Functor.Listable import qualified Data.Text.ICU.Convert as Convert import qualified Data.Text.ICU.Detect as Detect +import Diff +import Language +import Patch +import Prologue hiding (readFile) import Renderer -import Renderer.SExpression import Semantic import Source import System.FilePath +import Term -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO ByteString diffFilePaths paths = do blobs <- pure <$> traverse readFile paths - diffBlobPairs (SExpressionDiffRenderer TreeOnly) blobs + diffBlobPairs (const identity) (SExpressionDiffRenderer TreeOnly) blobs -- | Returns an s-expression parse tree for the specified FilePath. parseFilePath :: FilePath -> IO ByteString @@ -53,3 +57,7 @@ readFile path = do -- | Returns a Maybe Language based on the FilePath's extension. languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . toS . takeExtension + +-- | Extract a 'Diff' from a 'ListableF' enumerated by a property test. +unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation +unListableDiff diff = hoistFree (first unListableF) $ fmap unListableF <$> unListableF diff diff --git a/test/SummarySpec.hs b/test/SummarySpec.hs index 453b04d8e..15431be72 100644 --- a/test/SummarySpec.hs +++ b/test/SummarySpec.hs @@ -16,6 +16,7 @@ import Interpreter import Patch import Prologue import Source +import SpecHelpers import Syntax import Term import Test.Hspec (Spec, describe, it, parallel) @@ -99,6 +100,3 @@ isIndexedOrFixed' syntax = case syntax of isBranchNode :: Patch DiffInfo -> Bool isBranchNode = any isBranchInfo - -unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation -unListableDiff diff = hoistFree (first unListableF) $ fmap unListableF <$> unListableF diff diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 826725724..fe67d3489 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds, TypeOperators #-} module TOCSpec where import Data.Aeson import Category as C import Data.Functor.Both import Data.Functor.Listable -import RWS import Data.Record -import Data.String +import Data.Text.Listable +import Data.These import Diff import Info import Interpreter @@ -16,11 +17,12 @@ import Patch import Prologue hiding (fst, snd, readFile) import Renderer import Renderer.TOC +import RWS +import Semantic import Source +import SpecHelpers import Syntax as S import Term -import Semantic -import SpecHelpers import Test.Hspec (Spec, describe, it, parallel) import Test.Hspec.Expectations.Pretty import Test.Hspec.LeanCheck @@ -28,46 +30,67 @@ import Test.LeanCheck spec :: Spec spec = parallel $ do + describe "tableOfContentsBy" $ do + prop "drops all nodes with the constant Nothing function" $ + \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (unListableDiff diff :: Diff (Syntax ()) ()) `shouldBe` [] + + let diffSize = max 1 . sum . fmap (const 1) + let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a)) + prop "includes all nodes with a constant Just function" $ + \ diff -> let diff' = (unListableDiff diff :: Diff (Syntax ()) ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') () + + prop "produces an unchanged entry for identity diffs" $ + \ term -> let term' = (unListableF term :: Term (Syntax ()) (Record '[Category])) in tableOfContentsBy (Just . headF) (diffTerms term' term') `shouldBe` [Unchanged (lastValue term')] + + prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $ + \ patch -> let patch' = (unListableF <$> patch :: Patch (Term (Syntax ()) Int)) in tableOfContentsBy (Just . headF) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch')) + + prop "produces changed entries for relevant nodes containing irrelevant patches" $ + \ diff -> let diff' = fmap (1 <$) <$> mapAnnotations (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff (Syntax ()) Int])) in + tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe` + if Prologue.null diff' then [Unchanged 0] + else replicate (Prologue.length diff') (Changed 0) + describe "diffTOC" $ do it "blank if there are no methods" $ - diffTOC blankDiffBlobs blankDiff `shouldBe` [ ] + diffTOC blankDiff `shouldBe` [ ] it "summarizes changed methods" $ do sourceBlobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb") - Just diff <- diffBlobPair sourceBlobs - diffTOC sourceBlobs diff `shouldBe` + Just diff <- diffBlobPair declarationDecorator sourceBlobs + diffTOC diff `shouldBe` [ JSONSummary $ Summarizable C.SingletonMethod "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added" - , JSONSummary $ InSummarizable C.Method "bar" (sourceSpanBetween (4, 1) (6, 4)) + , JSONSummary $ Summarizable C.Method "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified" , JSONSummary $ Summarizable C.Method "baz" (sourceSpanBetween (4, 1) (5, 4)) "removed" ] it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (both "javascript/duplicate-parent.A.js" "javascript/duplicate-parent.B.js") - Just diff <- diffBlobPair sourceBlobs - diffTOC sourceBlobs diff `shouldBe` - [ JSONSummary $ InSummarizable C.Function "myFunction" (sourceSpanBetween (1, 1) (6, 2)) ] + Just diff <- diffBlobPair declarationDecorator sourceBlobs + diffTOC diff `shouldBe` + [ JSONSummary $ Summarizable C.Function "myFunction" (sourceSpanBetween (1, 1) (6, 2)) "modified" ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (both "javascript/erroneous-duplicate-method.A.js" "javascript/erroneous-duplicate-method.B.js") - Just diff <- diffBlobPair sourceBlobs - diffTOC sourceBlobs diff `shouldBe` + Just diff <- diffBlobPair declarationDecorator sourceBlobs + diffTOC diff `shouldBe` [ JSONSummary $ Summarizable C.Function "performHealthCheck" (sourceSpanBetween (8, 1) (29, 2)) "modified" ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (both "go/method-with-receiver.A.go" "go/method-with-receiver.B.go") - Just diff <- diffBlobPair sourceBlobs - diffTOC sourceBlobs diff `shouldBe` + Just diff <- diffBlobPair declarationDecorator sourceBlobs + diffTOC diff `shouldBe` [ JSONSummary $ Summarizable C.Method "(*apiClient) CheckAuth" (sourceSpanBetween (3,1) (3,101)) "added" ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (both "ruby/method-starts-with-two-identifiers.A.rb" "ruby/method-starts-with-two-identifiers.B.rb") - Just diff <- diffBlobPair sourceBlobs - diffTOC sourceBlobs diff `shouldBe` - [ JSONSummary $ InSummarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) ] + Just diff <- diffBlobPair declarationDecorator sourceBlobs + diffTOC diff `shouldBe` + [ JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (both "ruby/unicode.A.rb" "ruby/unicode.B.rb") - Just diff <- diffBlobPair sourceBlobs - diffTOC sourceBlobs diff `shouldBe` + Just diff <- diffBlobPair declarationDecorator sourceBlobs + diffTOC diff `shouldBe` [ JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (6, 1) (7, 4)) "added" ] prop "inserts of methods and functions are summarized" $ @@ -97,11 +120,11 @@ spec = parallel $ do prop "equal terms produce identity diffs" $ \a -> let term = defaultFeatureVectorDecorator (Info.category . headF) (unListableF a :: Term') in - diffTOC blankDiffBlobs (diffTerms term term) `shouldBe` [] + diffTOC (diffTerms term term) `shouldBe` [] describe "JSONSummary" $ do it "encodes InSummarizable to JSON" $ do - let summary = JSONSummary $ InSummarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) + let summary = JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" encode summary `shouldBe` "{\"span\":{\"start\":[1,1],\"end\":[4,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"modified\"}" it "encodes Summarizable to JSON" $ do @@ -111,60 +134,60 @@ spec = parallel $ do describe "diff with ToCRenderer" $ do it "produces JSON output" $ do blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb") - output <- diffBlobPairs ToCRenderer [blobs] + output <- diffBlobPairs declarationDecorator ToCRenderer [blobs] output `shouldBe` "{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" it "produces JSON output if there are parse errors" $ do blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.X.rb") - output <- diffBlobPairs ToCRenderer [blobs] - output `shouldBe` "{\"changes\":{},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\"}]}}\n" + output <- diffBlobPairs declarationDecorator ToCRenderer [blobs] + output `shouldBe` "{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\"}]}}\n" -type Diff' = SyntaxDiff String DefaultFields -type Term' = SyntaxTerm String DefaultFields +type Diff' = SyntaxDiff Text (Maybe Declaration ': DefaultFields) +type Term' = SyntaxTerm Text (Maybe Declaration ': DefaultFields) numTocSummaries :: Diff' -> Int -numTocSummaries diff = Prologue.length $ filter (not . isErrorSummary) (diffTOC blankDiffBlobs diff) +numTocSummaries diff = Prologue.length $ filter isValidSummary (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 = free $ Free (pure programInfo :< Indexed [ function' ]) +programWithChange body = wrap (pure programInfo :< Indexed [ function' ]) where - function' = free $ Free (pure functionInfo :< S.Function name' [] [ free $ Pure (Insert body) ] ) - name' = free $ Free (pure (Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo") + function' = wrap (pure (Just (FunctionDeclaration "foo") :. functionInfo) :< S.Function name' [] [ inserting body ] ) + name' = wrap (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo") -- Return a diff where term is inserted in the program, below a function found on both sides of the diff. programWithChangeOutsideFunction :: Term' -> Diff' -programWithChangeOutsideFunction term = free $ Free (pure programInfo :< Indexed [ function', term' ]) +programWithChangeOutsideFunction term = wrap (pure programInfo :< Indexed [ function', term' ]) where - function' = free $ Free (pure functionInfo :< S.Function name' [] [] ) - name' = free $ Free (pure (Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo") - term' = free $ Pure (Insert term) + function' = wrap (pure (Just (FunctionDeclaration "foo") :. functionInfo) :< S.Function name' [] [] ) + name' = wrap (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo") + term' = inserting term -programWithInsert :: String -> Term' -> Diff' -programWithInsert name body = programOf $ Insert (functionOf name body) +programWithInsert :: Text -> Term' -> Diff' +programWithInsert name body = programOf $ inserting (functionOf name body) -programWithDelete :: String -> Term' -> Diff' -programWithDelete name body = programOf $ Delete (functionOf name body) +programWithDelete :: Text -> Term' -> Diff' +programWithDelete name body = programOf $ deleting (functionOf name body) -programWithReplace :: String -> Term' -> Diff' -programWithReplace name body = programOf $ Replace (functionOf name body) (functionOf (name <> "2") body) +programWithReplace :: Text -> Term' -> Diff' +programWithReplace name body = programOf $ replacing (functionOf name body) (functionOf (name <> "2") body) -programOf :: Patch Term' -> Diff' -programOf patch = free $ Free (pure programInfo :< Indexed [ free $ Pure patch ]) +programOf :: Diff' -> Diff' +programOf diff = wrap (pure programInfo :< Indexed [ diff ]) -functionOf :: String -> Term' -> Term' -functionOf name body = cofree $ functionInfo :< S.Function name' [] [body] +functionOf :: Text -> Term' -> Term' +functionOf name body = cofree $ (Just (FunctionDeclaration name) :. functionInfo) :< S.Function name' [] [body] where - name' = cofree $ (Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name + name' = cofree $ (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name -programInfo :: Record DefaultFields -programInfo = Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil +programInfo :: Record (Maybe Declaration ': DefaultFields) +programInfo = Nothing :. Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil functionInfo :: Record DefaultFields functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil -- Filter tiers for terms that we consider "meaniningful" in TOC summaries. -isMeaningfulTerm :: ListableF (Term (Syntax leaf)) (Record DefaultFields) -> Bool +isMeaningfulTerm :: ListableF (Term (Syntax leaf)) a -> Bool isMeaningfulTerm a = case runCofree (unListableF a) of (_ :< S.Indexed _) -> False (_ :< S.Fixed _) -> False @@ -173,7 +196,7 @@ isMeaningfulTerm a = case runCofree (unListableF a) of _ -> True -- Filter tiers for terms if the Syntax is a Method or a Function. -isMethodOrFunction :: ListableF (Term (Syntax leaf)) (Record DefaultFields) -> Bool +isMethodOrFunction :: HasField fields Category => ListableF (Term (Syntax leaf)) (Record fields) -> Bool isMethodOrFunction a = case runCofree (unListableF a) of (_ :< S.Method{}) -> True (_ :< S.Function{}) -> True @@ -188,14 +211,14 @@ blobsForPaths = traverse (readFile . ("test/fixtures/toc/" <>)) sourceSpanBetween :: (Int, Int) -> (Int, Int) -> SourceSpan sourceSpanBetween (s1, e1) (s2, e2) = SourceSpan (SourcePos s1 e1) (SourcePos s2 e2) -blankDiff :: Diff (Syntax Text) (Record '[Category, Range, SourceSpan]) -blankDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "\"a\"")) ]) +blankDiff :: Diff' +blankDiff = wrap (pure arrayInfo :< Indexed [ inserting (cofree $ literalInfo :< Leaf "\"a\"") ]) where - arrayInfo = ArrayLiteral :. Range 0 3 :. sourceSpanBetween (1, 1) (1, 5) :. Nil - literalInfo = StringLiteral :. Range 1 2 :. sourceSpanBetween (1, 2) (1, 4) :. Nil + arrayInfo = Nothing :. Range 0 3 :. ArrayLiteral :. sourceSpanBetween (1, 1) (1, 5) :. Nil + literalInfo = Nothing :. Range 1 2 :. StringLiteral :. sourceSpanBetween (1, 2) (1, 4) :. Nil blankDiffBlobs :: Both SourceBlob blankDiffBlobs = both (SourceBlob (fromText "[]") nullOid "a.js" (Just defaultPlainBlob) (Just JavaScript)) (SourceBlob (fromText "[a]") nullOid "b.js" (Just defaultPlainBlob) (Just JavaScript)) -unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation -unListableDiff diff = hoistFree (first unListableF) $ fmap unListableF <$> unListableF diff +instance Listable Text where + tiers = unListableText `mapT` tiers