github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-21 13:51:44 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into diff-stdin

Browse Source
This commit is contained in:
Timothy Clem 2017-05-17 09:44:51 -07:00
commit 7ba950cf47
25 changed files with 434 additions and 383 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitmodules vendored
View File

@ -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

2
languages/python/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

26
languages/python/python.cabal Normal file
View File

@ -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

8
languages/python/src/Text/Parser/TreeSitter/Python.hs Normal file
View File

@ -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

1
languages/python/vendor/tree-sitter-python vendored Submodule

@ -0,0 +1 @@
Subproject commit 743cabab8c0b243082e497d2b677a7f703dc5c5d

3
semantic-diff.cabal
View File

@ -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

37
src/Arguments.hs
View File

@ -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)]

56
src/Data/Syntax/Assignment.hs
View File

@ -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

14
src/Diff.hs
View File

@ -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

10
src/Interpreter.hs
View File

@ -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

1
src/Language/Python.hs Normal file
View File

@ -0,0 +1 @@
module Language.Python where

1
src/Language/Python/Syntax.hs Normal file
View File

@ -0,0 +1 @@
module Language.Python.Syntax where

123
src/Language/Ruby/Syntax.hs
View File

@ -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'.

19
src/Patch.hs
View File

@ -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

12
src/Renderer.hs
View File

@ -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]

275
src/Renderer/TOC.hs
View File

@ -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)

22
src/Semantic.hs
View File

@ -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

2
src/SemanticCmdLine.hs
View File

@ -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

20
test/CommandSpec.hs
View File

@ -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)

6
test/DiffSpec.hs
View File

@ -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

16
test/InterpreterSpec.hs
View File

@ -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")) ])

1
test/SemanticSpec.hs
View File

@ -7,7 +7,6 @@ import Test.Hspec.Expectations.Pretty
import Language
import Syntax
import Renderer
import Renderer.SExpression
import Source
spec :: Spec

18
test/SpecHelpers.hs
View File

@ -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

4
test/SummarySpec.hs
View File

@ -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

137
test/TOCSpec.hs
View File

@ -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