github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-04 13:34:31 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into abstract-analysis-parsing

Browse Source
This commit is contained in:
Rob Rix 2019-10-18 18:07:45 -04:00
commit 1b0d2f8758
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
24 changed files with 264 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
semantic-java/src/Language/Java/Tags.hs
View File

@ -53,7 +53,7 @@ instance (ToTags l, ToTags r) => ToTagsBy 'Custom (l :+: r) where
instance ToTagsBy 'Custom Java.MethodDeclaration where
tags' t@Java.MethodDeclaration
{ ann = Loc range span
{ ann = loc@Loc { byteRange = range }
, name = Java.Identifier { text = name }
, body
} = do
@ -63,28 +63,28 @@ instance ToTagsBy 'Custom Java.MethodDeclaration where
Just Java.Block { ann = Loc Range { end } _ } -> end
Nothing -> end range
}
Tags.yield (Tag name Method span (Tags.firstLine sliced) Nothing)
Tags.yield (Tag name Method loc (Tags.firstLine sliced) Nothing)
gtags t
instance ToTagsBy 'Custom Java.ClassDeclaration where
tags' t@Java.ClassDeclaration
{ ann = Loc Range { start } span
{ ann = loc@Loc { byteRange = Range { start } }
, name = Java.Identifier { text = name }
, body = Java.ClassBody { ann = Loc Range { start = end } _ }
} = do
src <- ask @Source
let sliced = slice src (Range start end)
Tags.yield (Tag name Class span (Tags.firstLine sliced) Nothing)
Tags.yield (Tag name Class loc (Tags.firstLine sliced) Nothing)
gtags t
instance ToTagsBy 'Custom Java.MethodInvocation where
tags' t@Java.MethodInvocation
{ ann = Loc range span
{ ann = loc@Loc { byteRange = range }
, name = Java.Identifier { text = name }
} = do
src <- ask @Source
let sliced = slice src range
Tags.yield (Tag name Call span (Tags.firstLine sliced) Nothing)
Tags.yield (Tag name Call loc (Tags.firstLine sliced) Nothing)
gtags t

12
semantic-python/src/Language/Python/Tags.hs
View File

@ -57,36 +57,36 @@ instance (ToTags l, ToTags r) => ToTagsBy 'Custom (l :+: r) where
instance ToTagsBy 'Custom Py.FunctionDefinition where
tags' t@Py.FunctionDefinition
{ ann = Loc Range { start } span
{ ann = loc@Loc { byteRange = Range { start } }
, name = Py.Identifier { text = name }
, body = Py.Block { ann = Loc Range { start = end } _, extraChildren }
} = do
src <- ask @Source
let docs = listToMaybe extraChildren >>= docComment src
sliced = slice src (Range start end)
Tags.yield (Tag name Function span (Tags.firstLine sliced) docs)
Tags.yield (Tag name Function loc (Tags.firstLine sliced) docs)
gtags t
instance ToTagsBy 'Custom Py.ClassDefinition where
tags' t@Py.ClassDefinition
{ ann = Loc Range { start } span
{ ann = loc@Loc { byteRange = Range { start } }
, name = Py.Identifier { text = name }
, body = Py.Block { ann = Loc Range { start = end } _, extraChildren }
} = do
src <- ask @Source
let docs = listToMaybe extraChildren >>= docComment src
sliced = slice src (Range start end)
Tags.yield (Tag name Class span (Tags.firstLine sliced) docs)
Tags.yield (Tag name Class loc (Tags.firstLine sliced) docs)
gtags t
instance ToTagsBy 'Custom Py.Call where
tags' t@Py.Call
{ ann = Loc range span
{ ann = loc@Loc { byteRange = range }
, function = Py.PrimaryExpression (Prj Py.Identifier { text = name })
} = do
src <- ask @Source
let sliced = slice src range
Tags.yield (Tag name Call span (Tags.firstLine sliced) Nothing)
Tags.yield (Tag name Call loc (Tags.firstLine sliced) Nothing)
gtags t
tags' t@Py.Call{} = gtags t

4
semantic-tags/src/Tags/Tag.hs
View File

@ -4,12 +4,12 @@ module Tags.Tag
) where
import Data.Text (Text)
import Source.Span
import Source.Loc
data Tag = Tag
{ name :: Text
, kind :: Kind
, span :: Span
, loc :: Loc
, line :: Text
, docs :: Maybe Text
}

4
semantic-tags/src/Tags/Tagging/Precise.hs
View File

@ -15,7 +15,7 @@ import Data.Monoid (Endo(..))
import Data.Text as Text (Text, takeWhile)
import GHC.Generics
import Prelude hiding (span)
import Source.Loc (Loc)
import Source.Loc (Loc(..))
import Source.Span
import Source.Source as Source
import Tags.Tag
@ -28,7 +28,7 @@ class ToTags t where
yield :: (Carrier sig m, Member (Writer Tags) sig) => Tag -> m ()
yield = tell . Endo . (:) . modSpan toOneIndexed where
modSpan f t@Tag{ span = s } = t { span = f s }
modSpan f t@Tag{ loc = l } = t { loc = l { span = f (span l) } }
toOneIndexed (Span (Pos l1 c1) (Pos l2 c2)) = Span (Pos (l1 + 1) (c1 + 1)) (Pos (l2 + 1) (c2 + 1))
runTagging :: Source -> ReaderC Source (WriterC Tags PureC) () -> [Tag]

42
src/Analysis/TOCSummary.hs
View File

@ -10,8 +10,6 @@ module Analysis.TOCSummary
import Prologue hiding (project)
import Control.Arrow
import Control.Rewriting
import Data.Blob
import qualified Data.Error as Error
import Data.Flag
@ -29,13 +27,13 @@ import Source.Source as Source
data Declaration = Declaration
{ kind :: Kind
, identifier :: Text
, text :: Text
, span :: Span
, language :: Language }
, language :: Language
}
deriving (Eq, Show)
formatIdentifier :: Declaration -> Text
formatIdentifier (Declaration kind identifier _ _ lang) = case kind of
formatIdentifier (Declaration kind identifier _ lang) = case kind of
Method (Just receiver)
| Language.Go <- lang -> "(" <> receiver <> ") " <> identifier
| otherwise -> receiver <> "." <> identifier
@ -98,7 +96,7 @@ instance HasDeclarationBy 'Default syntax where
-- | Produce a 'Heading' from the first line of the heading of a 'Markdown.Heading' node.
instance HasDeclarationBy 'Custom Markdown.Heading where
toDeclarationBy blob@Blob{..} ann (Markdown.Heading level terms _)
= Just $ Declaration (Heading level) (headingText terms) mempty (Loc.span ann) (blobLanguage blob)
= Just $ Declaration (Heading level) (headingText terms) (Loc.span ann) (blobLanguage blob)
where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
headingByteRange (Term (In ann _), _) = byteRange ann
getSource = firstLine . toText . Source.slice blobSource
@ -107,48 +105,30 @@ instance HasDeclarationBy 'Custom Markdown.Heading where
-- | Produce an 'Error' for 'Syntax.Error' nodes.
instance HasDeclarationBy 'Custom Syntax.Error where
toDeclarationBy blob@Blob{..} ann err@Syntax.Error{}
= Just $ Declaration Error (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob)
= Just $ Declaration Error (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) (Loc.span ann) (blobLanguage blob)
where formatTOCError e = Error.showExpectation (flag Error.Colourize False) (Error.errorExpected e) (Error.errorActual e) ""
-- | Produce a 'Function' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range').
instance HasDeclarationBy 'Custom Declaration.Function where
toDeclarationBy blob@Blob{..} ann decl@(Declaration.Function _ (Term (In identifierAnn _), _) _ _)
toDeclarationBy blob@Blob{..} ann (Declaration.Function _ (Term (In identifierAnn _), _) _ _)
-- Do not summarize anonymous functions
| isEmpty identifierAnn = Nothing
-- Named functions
| otherwise = Just $ Declaration Function (getSource blobSource identifierAnn) functionSource (Loc.span ann) (blobLanguage blob)
| otherwise = Just $ Declaration Function (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob)
where isEmpty = (== 0) . rangeLength . byteRange
functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl)
-- | Produce a 'Method' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'.
instance HasDeclarationBy 'Custom Declaration.Method where
toDeclarationBy blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _)
toDeclarationBy blob@Blob{..} ann (Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _)
-- Methods without a receiver
| isEmpty receiverAnn = Just $ Declaration (Method Nothing) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob)
| isEmpty receiverAnn = Just $ Declaration (Method Nothing) (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob)
-- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
| blobLanguage blob == Go
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ Declaration (Method (Just (getSource blobSource receiverType))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob)
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ Declaration (Method (Just (getSource blobSource receiverType))) (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob)
-- Methods with a receiver (class methods) are formatted like `receiver.method_name`
| otherwise = Just $ Declaration (Method (Just (getSource blobSource receiverAnn))) (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob)
| otherwise = Just $ Declaration (Method (Just (getSource blobSource receiverAnn))) (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob)
where
isEmpty = (== 0) . rangeLength . byteRange
methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl)
-- When encountering a Declaration-annotated term, we need to extract a Text
-- for the resulting Declaration's 'identifier' field. This text
-- is constructed by slicing out text from the original blob corresponding
-- to a location, which is found via the passed-in rule.
getIdentifier :: Functor m
=> Rewrite (m (Term syntax Loc)) (Term syntax Loc)
-> Blob
-> TermF m Loc (Term syntax Loc, a)
-> Text
getIdentifier finder Blob{..} (In a r)
= let declRange = byteRange a
bodyRange = byteRange <$> rewrite (fmap fst r) (finder >>^ annotation)
-- Text-based gyrations to slice the identifier out of the provided blob source
sliceFrom = T.stripEnd . toText . Source.slice blobSource . subtractRange declRange
in maybe mempty sliceFrom bodyRange
getSource :: Source -> Loc -> Text
getSource blobSource = toText . Source.slice blobSource . byteRange

11
src/Control/Effect/Parse.hs
View File

@ -10,7 +10,7 @@ module Control.Effect.Parse
import Control.Effect.Carrier
import Control.Effect.Error
import Control.Exception (SomeException)
import Data.Bifunctor.Join
import Data.Bitraversable
import Data.Blob
import Data.Language
import qualified Data.Map as Map
@ -51,10 +51,11 @@ parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of
-- | Parse a 'BlobPair' with one of the provided parsers, and run an action on the abstracted term pair.
parsePairWith
:: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig)
=> Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from.
-> (forall term . c term => These (term ann) (term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@.
-> BlobPair -- ^ The blob pair to parse.
=> Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from.
-> (forall term . c term => These (Blob, term ann) (Blob, term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@.
-> BlobPair -- ^ The blob pair to parse.
-> m a
parsePairWith parsers with blobPair = case Map.lookup (languageForBlobPair blobPair) parsers of
Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with . runJoin
Just (SomeParser parser) -> bitraverse (p parser) (p parser) (getBlobPair blobPair) >>= with
_ -> noLanguageForBlob (pathForBlobPair blobPair)
where p parser blob = (,) blob <$> parse parser blob

13
src/Data/Blob.hs
View File

@ -13,7 +13,7 @@ module Data.Blob
, nullBlob
, sourceBlob
, noLanguageForBlob
, type BlobPair
, BlobPair(..)
, pattern Diffing
, pattern Inserting
, pattern Deleting
@ -101,7 +101,8 @@ noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPa
-- | Represents a blobs suitable for diffing which can be either a blob to
-- delete, a blob to insert, or a pair of blobs to diff.
type BlobPair = Join These Blob
newtype BlobPair = BlobPair { getBlobPair :: These Blob Blob }
deriving (Eq, Show)
instance FromJSON BlobPair where
parseJSON = withObject "BlobPair" $ \o -> do
@ -114,13 +115,13 @@ instance FromJSON BlobPair where
_ -> Prelude.fail "Expected object with 'before' and/or 'after' keys only"
pattern Diffing :: Blob -> Blob -> BlobPair
pattern Diffing a b = Join (These a b)
pattern Diffing a b = BlobPair (These a b)
pattern Inserting :: Blob -> BlobPair
pattern Inserting a = Join (That a)
pattern Inserting a = BlobPair (That a)
pattern Deleting :: Blob -> BlobPair
pattern Deleting b = Join (This b)
pattern Deleting b = BlobPair (This b)
{-# COMPLETE Diffing, Inserting, Deleting #-}
@ -151,7 +152,7 @@ languageTagForBlobPair pair = showLanguage (languageForBlobPair pair)
where showLanguage = pure . (,) "language" . show
pathKeyForBlobPair :: BlobPair -> FilePath
pathKeyForBlobPair blobs = case bimap blobPath blobPath (runJoin blobs) of
pathKeyForBlobPair blobs = case bimap blobPath blobPath (getBlobPair blobs) of
This before -> before
That after -> after
These before after | before == after -> after

28
src/Diffing/Algorithm/RWS.hs
View File

@ -19,7 +19,7 @@ import Data.Diff (DiffF(..), deleting, inserting, merge, replacing)
import qualified Data.KdMap.Static as KdMap
import Data.List (sortOn)
import Data.Term as Term
import Diffing.Algorithm
import Diffing.Algorithm (Diffable(..))
import Diffing.Algorithm.RWS.FeatureVector
import Diffing.Algorithm.SES
import Prologue
@ -34,10 +34,10 @@ rws :: (Foldable syntax, Functor syntax, Diffable syntax)
-> (Term syntax (FeatureVector, ann1) -> Term syntax (FeatureVector, ann2) -> Bool)
-> [Term syntax (FeatureVector, ann1)]
-> [Term syntax (FeatureVector, ann2)]
-> EditScript (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))
rws _ _ as [] = This <$> as
rws _ _ [] bs = That <$> bs
rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a]
-> [Edit (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))]
rws _ _ as [] = Delete <$> as
rws _ _ [] bs = Insert <$> bs
rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [Copy a b] else [Insert b, Delete a]
rws canCompare equivalent as bs
= ses equivalent as bs
& mapContiguous [] []
@ -46,18 +46,18 @@ rws canCompare equivalent as bs
-- Map contiguous sequences of unmapped terms separated by SES-mapped equivalencies.
mapContiguous as bs [] = mapSimilar (reverse as) (reverse bs)
mapContiguous as bs (first : rest) = case first of
This a -> mapContiguous (a : as) bs rest
That b -> mapContiguous as (b : bs) rest
These _ _ -> mapSimilar (reverse as) (reverse bs) <> (first : mapContiguous [] [] rest)
Delete a -> mapContiguous (a : as) bs rest
Insert b -> mapContiguous as (b : bs) rest
Copy _ _ -> mapSimilar (reverse as) (reverse bs) <> (first : mapContiguous [] [] rest)
-- Map comparable, mutually similar terms, inserting & deleting surrounding terms.
mapSimilar as' bs' = go as bs
where go as [] = This . snd <$> as
go [] bs = That . snd <$> bs
go [a] [b] | canCompareTerms canCompare (snd a) (snd b) = [These (snd a) (snd b)]
| otherwise = [That (snd b), This (snd a)]
where go as [] = Delete . snd <$> as
go [] bs = Insert . snd <$> bs
go [a] [b] | canCompareTerms canCompare (snd a) (snd b) = [Copy (snd a) (snd b)]
| otherwise = [Insert (snd b), Delete (snd a)]
go as@((i, _) : _) ((j, b) : restB) =
fromMaybe (That b : go as restB) $ do
fromMaybe (Insert b : go as restB) $ do
-- Look up the most similar term to b near i.
(i', a) <- mostSimilarMatching (\ i' a -> inRange (i, i + optionsLookaheadPlaces) i' && canCompareTerms canCompare a b) kdMapA b
-- Look up the most similar term to a near j.
@ -66,7 +66,7 @@ rws canCompare equivalent as bs
guard (j == j')
-- Delete any elements of as before the selected element.
let (deleted, _ : restA) = span ((< i') . fst) as
pure $! (This . snd <$> deleted) <> (These a b : go restA restB)
pure $! (Delete . snd <$> deleted) <> (Copy a b : go restA restB)
(as, bs) = (zip [0..] as', zip [0..] bs')
(kdMapA, kdMapB) = (toKdMap as, toKdMap bs)

40
src/Diffing/Algorithm/SES.hs
View File

@ -1,27 +1,45 @@
{-# LANGUAGE BangPatterns, GADTs, MultiParamTypeClasses, ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns, GADTs, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables #-}
module Diffing.Algorithm.SES
( EditScript
( Edit(..)
, toThese
, ses
) where
import Data.Array ((!))
import qualified Data.Array as Array
import Data.Bifunctor
import Data.Foldable (find, toList)
import Data.Ix
import Data.These
-- | An edit script, i.e. a sequence of changes/copies of elements.
type EditScript a b = [These a b]
data Edit a b
= Delete a
| Insert b
| Copy a b
deriving (Eq, Functor, Ord, Show)
data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: EditScript a b }
instance Bifunctor Edit where
bimap f g = \case
Delete a -> Delete (f a)
Insert b -> Insert (g b)
Copy a b -> Copy (f a) (g b)
toThese :: Edit a b -> These a b
toThese = \case
Delete a -> This a
Insert b -> That b
Copy a b -> These a b
data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: [Edit a b] }
deriving (Eq, Show)
-- | Compute the shortest edit script using Myers’ algorithm.
ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> EditScript a b
ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> [Edit a b]
ses eq as' bs'
| null bs = This <$> toList as
| null as = That <$> toList bs
| null bs = Delete <$> toList as
| null as = Insert <$> toList bs
| otherwise = reverse (searchUpToD 0 (Array.array (1, 1) [(1, Endpoint 0 (-1) [])]))
where (as, bs) = (Array.listArray (0, pred n) (toList as'), Array.listArray (0, pred m) (toList bs'))
(!n, !m) = (length as', length bs')
@ -49,19 +67,19 @@ ses eq as' bs'
moveRightFrom left
-- | Move downward from a given vertex, inserting the element for the corresponding row.
moveDownFrom (Endpoint x y script) = Endpoint x (succ y) $ maybe script ((: script) . That) (bs !? y)
moveDownFrom (Endpoint x y script) = Endpoint x (succ y) $ maybe script ((: script) . Insert) (bs !? y)
{-# INLINE moveDownFrom #-}
-- | Move rightward from a given vertex, deleting the element for the corresponding column.
moveRightFrom (Endpoint x y script) = Endpoint (succ x) y $ maybe script ((: script) . This) (as !? x)
moveRightFrom (Endpoint x y script) = Endpoint (succ x) y $ maybe script ((: script) . Delete) (as !? x)
{-# INLINE moveRightFrom #-}
-- | Slide down any diagonal edges from a given vertex.
slideFrom (Endpoint x y script)
| Just a <- as !? x
, Just b <- bs !? y
, a `eq` b = slideFrom (Endpoint (succ x) (succ y) (These a b : script))
| otherwise = Endpoint x y script
, a `eq` b = slideFrom (Endpoint (succ x) (succ y) (Copy a b : script))
| otherwise = Endpoint x y script
(!?) :: Ix i => Array.Array i a -> i -> Maybe a

5
src/Diffing/Interpreter.hs
View File

@ -12,6 +12,7 @@ import qualified Data.Diff as Diff
import Data.Term
import Diffing.Algorithm
import Diffing.Algorithm.RWS
import Diffing.Algorithm.SES (toThese)
import Prologue
-- | Diff two à la carte terms recursively.
@ -30,7 +31,7 @@ stripDiff :: Functor syntax
stripDiff = bimap snd snd
-- | The class of term types for which we can compute a diff.
class (Bifoldable (DiffFor term)) => DiffTerms term where
class Bifoldable (DiffFor term) => DiffTerms term where
-- | The type of diffs for the given term type.
--
-- Note that the dependency means that the diff type is in 1:1 correspondence with the term type. This allows subclasses of 'DiffTerms' to receive e.g. @'DiffFor' term a b@ without incurring ambiguity, since every diff type is unique to its term type.
@ -72,7 +73,7 @@ instance ( Alternative m
eff (L op) = case op of
Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k
Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k
RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= k
RWS as bs k -> traverse (runDiff . diffThese . toThese) (rws comparableTerms equivalentTerms as bs) >>= k
Delete a k -> k (Diff.deleting a)
Insert b k -> k (Diff.inserting b)
Replace a b k -> k (Diff.replacing a b)

4
src/Rendering/JSON.hs
View File

@ -56,8 +56,8 @@ newtype JSONStat = JSONStat { jsonStatBlobs :: BlobPair }
deriving (Eq, Show)
instance ToJSON JSONStat where
toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs)))
toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs))))
toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (getBlobPair jsonStatBlobs)))
toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (getBlobPair jsonStatBlobs))))
-- | Render a term to a value representing its JSON.
renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON

11
src/Rendering/TOC.hs
View File

@ -7,6 +7,7 @@ module Rendering.TOC
, Change(..)
, tableOfContentsBy
, dedupe
, summarizeChange
) where
import Prologue hiding (index)
@ -113,13 +114,13 @@ dedupe
| otherwise -> Map.insert key d { change = Replaced, decl = similar } m
_ -> Map.insert key d m
dedupeKey (Declaration kind ident _ _ _) = DedupeKey kind (T.toLower ident)
dedupeKey (Declaration kind ident _ _) = DedupeKey kind (T.toLower ident)
-- | Construct a 'TOCSummary' from a node annotation and a change type label.
recordSummary :: Change -> Declaration -> Either ErrorSummary TOCSummary
recordSummary change decl@(Declaration kind text _ srcSpan language)
-- | Construct a 'TOCSummary' or 'ErrorSummary' from a 'Change' and 'Declaration'.
summarizeChange :: Change -> Declaration -> Either ErrorSummary TOCSummary
summarizeChange change decl@(Declaration kind text srcSpan language)
| Error <- kind = Left $ ErrorSummary text srcSpan language
| otherwise = Right $ TOCSummary kind (formatIdentifier decl) srcSpan change
diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [Either ErrorSummary TOCSummary]
diffTOC = map (uncurry recordSummary) . dedupe . tableOfContentsBy declaration
diffTOC = map (uncurry summarizeChange) . dedupe . tableOfContentsBy declaration

43
src/Semantic/Api/Diffs.hs
View File

@ -4,16 +4,12 @@ module Semantic.Api.Diffs
, DiffOutputFormat(..)
, diffGraph
, decoratingDiffWith
, DiffEffects
, summarizeDiffParsers
, SummarizeDiff(..)
, diffTerms
) where
import Analysis.ConstructorName (ConstructorName)
import Analysis.Decorator (decoratorWithAlgebra)
import Analysis.TOCSummary (Declaration, HasDeclaration, declarationAlgebra)
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
@ -38,7 +34,6 @@ import Proto.Semantic_JSON()
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Rendering.TOC
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Task as Task
@ -149,18 +144,6 @@ instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Show1 syntax, Traversab
showDiff = serialize Show
summarizeDiffParsers :: Map Language (SomeParser SummarizeDiff Loc)
summarizeDiffParsers = aLaCarteParsers
class DiffTerms term => SummarizeDiff term where
decorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
summarizeDiff :: DiffFor term (Maybe Declaration) (Maybe Declaration) -> [Either ErrorSummary TOCSummary]
instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where
decorateTerm = decoratorWithAlgebra . declarationAlgebra
summarizeDiff = diffTOC
-- | Parse a 'BlobPair' using one of the provided parsers, diff the resulting terms, and run an action on the abstracted diff.
--
-- This allows us to define features using an abstract interface, and use them with diffs for any parser whose terms support that interface.
@ -170,26 +153,12 @@ diffWith
-> (forall term . c term => DiffFor term Loc Loc -> m output) -- ^ A function to run on the computed diff. Note that the diff is abstract (it’s the diff type corresponding to an abstract term type), but the term type is constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@.
-> BlobPair -- ^ The blob pair to parse.
-> m output
diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms blobPair) blobPair
-- | Parse a 'BlobPair' using one of the provided parsers, decorate the resulting terms, diff them, and run an action on the abstracted diff.
--
-- This allows us to define features using an abstract interface, and use them with diffs for any parser whose terms support that interface.
decoratingDiffWith
:: forall ann c output m sig
. (forall term . c term => DiffTerms term, DiffEffects sig m)
=> Map Language (SomeParser c Loc) -- ^ The set of parsers to select from.
-> (forall term . c term => Blob -> term Loc -> term ann) -- ^ A function to decorate the terms, replacing their annotations and thus the annotations in the resulting diff.
-> (forall term . c term => DiffFor term ann ann -> m output) -- ^ A function to run on the computed diff. Note that the diff is abstract (it’s the diff type corresponding to an abstract term type), but the term type is constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@.
-> BlobPair -- ^ The blob pair to parse.
-> m output
decoratingDiffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . bimap (decorate blobL) (decorate blobR)) blobPair where
(blobL, blobR) = fromThese errorBlob errorBlob (runJoin blobPair)
errorBlob = Prelude.error "evaluating blob on absent side"
diffWith parsers render = parsePairWith parsers (render <=< diffTerms)
diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m)
=> BlobPair -> These (term ann) (term ann) -> m (DiffFor term ann ann)
diffTerms blobs terms = time "diff" languageTag $ do
let diff = diffTermPair terms
=> These (Blob, term ann) (Blob, term ann) -> m (DiffFor term ann ann)
diffTerms terms = time "diff" languageTag $ do
let diff = diffTermPair (bimap snd snd terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
where languageTag = languageTagForBlobPair blobs
blobs = BlobPair (bimap fst fst terms)

22
src/Semantic/Api/Symbols.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE MonoLocalBinds, RankNTypes #-}
{-# LANGUAGE DerivingVia, MonoLocalBinds, RankNTypes, StandaloneDeriving #-}
module Semantic.Api.Symbols
( legacyParseSymbols
, parseSymbols
@ -29,7 +29,7 @@ import qualified Semantic.Api.LegacyTypes as Legacy
import Semantic.Config
import Semantic.Task
import Serializing.Format (Format)
import Source.Loc
import Source.Loc as Loc
import Source.Source
import Tags.Taggable
import Tags.Tagging
@ -59,7 +59,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
{ symbolName = name
, symbolKind = pack (show kind)
, symbolLine = line
, symbolSpan = converting #? span
, symbolSpan = converting #? Loc.span loc
}
parseSymbolsBuilder :: (Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader Config) sig, Member (Reader PerLanguageModes) sig, Carrier sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
@ -99,7 +99,7 @@ parseSymbols blobs = do
& P.symbol .~ name
& P.kind .~ pack (show kind)
& P.line .~ line
& P.maybe'span .~ converting #? span
& P.maybe'span ?~ converting # Loc.span loc
& P.maybe'docs .~ fmap (flip (set P.docstring) defMessage) docs
symbolsToSummarize :: [Text]
@ -111,14 +111,16 @@ class ToTags t where
instance IsTaggable syntax => ToTags (Term syntax) where
tags = runTagging
instance ToTags Java.Term where
tags _ _ = Precise.tags
instance ToTags JSON.Term where
tags _ _ = Precise.tags
deriving via (ViaPrecise Java.Term) instance ToTags Java.Term
deriving via (ViaPrecise JSON.Term) instance ToTags JSON.Term
deriving via (ViaPrecise Python.Term) instance ToTags Python.Term
instance ToTags Python.Term where
tags _ _ = Precise.tags
newtype ViaPrecise t a = ViaPrecise (t a)
instance Precise.ToTags t => ToTags (ViaPrecise t) where
tags _ _ src (ViaPrecise t) = Precise.tags src t
toTagsParsers :: PerLanguageModes -> Map Language (Parser.SomeParser ToTags Loc)

93
src/Semantic/Api/TOCSummaries.hs
View File

@ -1,47 +1,80 @@
{-# LANGUAGE LambdaCase #-}
module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
{-# LANGUAGE DerivingVia, LambdaCase, MonoLocalBinds, StandaloneDeriving, TupleSections #-}
module Semantic.Api.TOCSummaries
( diffSummary
, legacyDiffSummary
, diffSummaryBuilder
, SummarizeDiff(..)
, summarizeDiffParsers
) where
import Analysis.TOCSummary (formatKind)
import Analysis.Decorator (decoratorWithAlgebra)
import Analysis.TOCSummary (Declaration(..), HasDeclaration, Kind(..), declarationAlgebra, formatKind)
import Control.Applicative (liftA2)
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Lens
import Control.Monad.IO.Class
import Data.Aeson
import Data.Blob
import Data.ByteString.Builder
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.Functor.Classes
import Data.Hashable.Lifted
import Data.Language (Language, PerLanguageModes)
import Data.Map (Map)
import qualified Data.Map.Monoidal as Map
import Data.Maybe (mapMaybe)
import Data.ProtoLens (defMessage)
import Data.Semilattice.Lower
import Data.Term (Term)
import qualified Data.Text as T
import Data.These (These, fromThese)
import Diffing.Algorithm (Diffable)
import qualified Diffing.Algorithm.SES as SES
import qualified Language.Java as Java
import qualified Language.JSON as JSON
import qualified Language.Python as Python
import Parsing.Parser (SomeParser, allParsers)
import Proto.Semantic as P hiding (Blob, BlobPair)
import Proto.Semantic_Fields as P
import Rendering.TOC
import Semantic.Api.Bridge
import Semantic.Api.Diffs
import Semantic.Config (Config)
import Semantic.Task as Task
import Serializing.Format
import Source.Loc as Loc
import Source.Source as Source
import qualified Tags.Tag as Tag
import qualified Tags.Tagging.Precise as Tagging
diffSummaryBuilder :: DiffEffects sig m => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder
diffSummaryBuilder :: (Carrier sig m, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader Config) sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder
diffSummaryBuilder format blobs = diffSummary blobs >>= serialize format
legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries
legacyDiffSummary :: (Carrier sig m, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => [BlobPair] -> m Summaries
legacyDiffSummary = distributeFoldMap go
where
go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry (flip Summaries) . bimap toMap toMap . partitionEithers . summarizeDiff) blobPair
go :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => BlobPair -> m Summaries
go blobPair = asks summarizeDiffParsers >>= \ p -> parsePairWith p (fmap (uncurry (flip Summaries) . bimap toMap toMap . partitionEithers) . summarizeTerms) blobPair
`catchError` \(SomeException e) ->
pure $ Summaries mempty (toMap [ErrorSummary (T.pack (show e)) lowerBound lang])
where path = T.pack $ pathKeyForBlobPair blobPair
lang = languageForBlobPair blobPair
toMap :: ToJSON a => [a] -> Map.Map T.Text [Value]
toMap [] = mempty
toMap as = Map.singleton path (toJSON <$> as)
diffSummary :: DiffEffects sig m => [BlobPair] -> m DiffTreeTOCResponse
diffSummary :: (Carrier sig m, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => [BlobPair] -> m DiffTreeTOCResponse
diffSummary blobs = do
diff <- distributeFor blobs go
pure $ defMessage & P.files .~ diff
where
go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . uncurry toFile . partitionEithers . map (bimap toError toChange) . summarizeDiff) blobPair
go :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => BlobPair -> m TOCSummaryFile
go blobPair = asks summarizeDiffParsers >>= \ p -> parsePairWith p (fmap (uncurry toFile . partitionEithers . map (bimap toError toChange)) . summarizeTerms) blobPair
`catchError` \(SomeException e) ->
pure $ toFile [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] []
where toFile errors changes = defMessage
@ -68,3 +101,47 @@ toError :: ErrorSummary -> TOCSummaryError
toError ErrorSummary{..} = defMessage
& P.error .~ message
& P.maybe'span ?~ converting # span
summarizeDiffParsers :: PerLanguageModes -> Map Language (SomeParser SummarizeDiff Loc)
summarizeDiffParsers = allParsers
class SummarizeDiff term where
summarizeTerms :: (Member Telemetry sig, Carrier sig m, MonadIO m) => These (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary]
instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where
summarizeTerms = fmap diffTOC . diffTerms . bimap decorateTerm decorateTerm where
decorateTerm :: (Foldable syntax, Functor syntax, HasDeclaration syntax) => (Blob, Term syntax Loc) -> (Blob, Term syntax (Maybe Declaration))
decorateTerm (blob, term) = (blob, decoratorWithAlgebra (declarationAlgebra blob) term)
deriving via (ViaTags Java.Term) instance SummarizeDiff Java.Term
deriving via (ViaTags JSON.Term) instance SummarizeDiff JSON.Term
deriving via (ViaTags Python.Term) instance SummarizeDiff Python.Term
newtype ViaTags t a = ViaTags (t a)
instance Tagging.ToTags t => SummarizeDiff (ViaTags t) where
summarizeTerms terms = pure . map (uncurry summarizeChange) . dedupe . mapMaybe toChange . uncurry (SES.ses compare) . fromThese [] [] . bimap (uncurry go) (uncurry go) $ terms where
go blob (ViaTags t) = Tagging.tags (blobSource blob) t
lang = languageForBlobPair (BlobPair (bimap fst fst terms))
(s1, s2) = fromThese mempty mempty (bimap (blobSource . fst) (blobSource . fst) terms)
compare = liftA2 (&&) <$> ((==) `on` Tag.kind) <*> ((==) `on` Tag.name)
toChange = \case
SES.Delete tag -> (Deleted,) <$> toDecl tag
SES.Insert tag -> (Inserted,) <$> toDecl tag
SES.Copy t1 t2
| Source.slice s1 (byteRange (Tag.loc t1)) /= Source.slice s2 (byteRange (Tag.loc t2))
-> (Changed,) <$> toDecl t2
| otherwise -> Nothing
toDecl (Tag.Tag name kind loc _ _) = do
kind <- toKind kind
pure (Declaration kind name (Loc.span loc) lang)
toKind = \case
Tag.Function -> Just Function
Tag.Method -> Just (Method Nothing)
_ -> Nothing

18
src/Semantic/CLI.hs
View File

@ -92,6 +92,7 @@ diffCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
where
diffArgumentsParser = do
languageModes <- languageModes
renderer <- flag (parseDiffBuilder DiffSExpression) (parseDiffBuilder DiffSExpression) (long "sexpression" <> help "Output s-expression diff tree (default)")
<|> flag' (parseDiffBuilder DiffJSONTree) (long "json" <> help "Output JSON diff trees")
<|> flag' (parseDiffBuilder DiffJSONGraph) (long "json-graph" <> help "Output JSON diff trees")
@ -99,18 +100,13 @@ diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute change
<|> flag' (parseDiffBuilder DiffDotGraph) (long "dot" <> help "Output the diff as a DOT graph")
<|> flag' (parseDiffBuilder DiffShow) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
filesOrStdin <- Right <$> some (Both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
pure $ Task.readBlobPairs filesOrStdin >>= renderer
pure $ Task.readBlobPairs filesOrStdin >>= runReader languageModes . renderer
parseCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
where
parseArgumentsParser = do
languageModes <- Language.PerLanguageModes
<$> option auto ( long "python-mode"
<> help "The AST representation to use for Python sources"
<> metavar "ALaCarte|Precise"
<> value Language.ALaCarte
<> showDefault)
languageModes <- languageModes
renderer
<- flag (parseTermBuilder TermSExpression)
(parseTermBuilder TermSExpression)
@ -179,6 +175,14 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
makeReadProjectRecursivelyTask language rootDir excludeDirs dir = Task.readProject rootDir dir language excludeDirs
makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer
languageModes :: Parser Language.PerLanguageModes
languageModes = Language.PerLanguageModes
<$> option auto ( long "python-mode"
<> help "The AST representation to use for Python sources"
<> metavar "ALaCarte|Precise"
<> value Language.ALaCarte
<> showDefault)
shaReader :: ReadM Git.OID
shaReader = eitherReader parseSha
where parseSha arg = if length arg == 40 || arg == "HEAD"

8
src/Tags/Taggable.hs
View File

@ -49,7 +49,7 @@ import qualified Language.TypeScript.Syntax as TypeScript
data Token
= Enter { tokenName :: Text, tokenSnippetRange :: Range }
| Exit { tokenName :: Text, tokenSnippetRange :: Range}
| Iden { identifierName :: Text, tokenSpan :: Span, docsLiteralRange :: Maybe Range }
| Iden { identifierName :: Text, tokenLoc :: Loc, docsLiteralRange :: Maybe Range }
deriving (Eq, Show)
type Tagger = Stream (Of Token)
@ -58,8 +58,8 @@ enter, exit :: Monad m => String -> Range -> Tagger m ()
enter c = yield . Enter (pack c)
exit c = yield . Exit (pack c)
emitIden :: Monad m => Span -> Maybe Range -> Name -> Tagger m ()
emitIden span docsLiteralRange name = yield (Iden (formatName name) span docsLiteralRange)
emitIden :: Monad m => Loc -> Maybe Range -> Name -> Tagger m ()
emitIden loc docsLiteralRange name = yield (Iden (formatName name) loc docsLiteralRange)
class Taggable constr where
docsLiteral ::
@ -115,7 +115,7 @@ descend lang t@(In loc _) = do
let litRange = docsLiteral lang term
enter (constructorName term) snippetRange
maybe (pure ()) (emitIden (Loc.span loc) litRange) (symbolName term)
maybe (pure ()) (emitIden loc litRange) (symbolName term)
traverse_ subtermRef t
exit (constructorName term) snippetRange

6
src/Tags/Tagging.hs
View File

@ -57,11 +57,11 @@ contextualizing :: ( Member (State [ContextToken]) sig
contextualizing source toKind = Streaming.mapMaybeM $ \case
Enter x r -> Nothing <$ enterScope (x, r)
Exit x r -> Nothing <$ exitScope (x, r)
Iden iden span docsLiteralRange -> get @[ContextToken] >>= pure . \case
Iden iden loc docsLiteralRange -> get @[ContextToken] >>= pure . \case
((x, r):("Context", cr):_) | Just kind <- toKind x
-> Just $ Tag iden kind span (firstLine (slice r)) (Just (slice cr))
-> Just $ Tag iden kind loc (firstLine (slice r)) (Just (slice cr))
((x, r):_) | Just kind <- toKind x
-> Just $ Tag iden kind span (firstLine (slice r)) (slice <$> docsLiteralRange)
-> Just $ Tag iden kind loc (firstLine (slice r)) (slice <$> docsLiteralRange)
_ -> Nothing
where
slice = stripEnd . Source.toText . Source.slice source

2
test/Data/Functor/Listable.hs
View File

@ -216,7 +216,7 @@ instance Listable Text where
tiers = pack `mapT` tiers
instance Listable ToC.Declaration where
tiers = cons5 ToC.Declaration
tiers = cons4 ToC.Declaration
instance Listable ToC.Kind where
tiers

7
test/Diffing/Algorithm/RWS/Spec.hs
View File

@ -8,9 +8,10 @@ import Data.Sum
import qualified Data.Syntax as Syntax
import Data.Term
import Data.These
import Diffing.Algorithm
import Diffing.Algorithm (comparableTerms)
import Diffing.Interpreter (stripDiff)
import Diffing.Algorithm.RWS
import Diffing.Algorithm.SES
import Diffing.Interpreter.Spec (afterTerm, beforeTerm)
import Test.Hspec.LeanCheck
import SpecHelpers
@ -30,12 +31,12 @@ spec = do
\ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax ()])
tbs = decorate <$> (bs :: [Term ListableSyntax ()])
wrap = termIn emptyAnnotation . inject
diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffThese . toThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (wrap (stripTerm <$> tas)), Just (wrap (stripTerm <$> tbs)))
it "produces unbiased insertions within branches" $
let (a, b) = (decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "a")) ])), decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "b")) ]))) in
fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ Insert a, Copy b b ]
where decorate = defaultFeatureVectorDecorator

8
test/Diffing/Algorithm/SES/Spec.hs
View File

@ -9,16 +9,16 @@ spec :: Spec
spec = do
describe "ses" $ do
prop "returns equal lists in These" $
\ as -> (ses (==) as as :: EditScript Char Char) `shouldBe` zipWith These as as
\ as -> (ses (==) as as :: [Edit Char Char]) `shouldBe` zipWith Copy as as
prop "returns deletions in This" $
\ as -> (ses (==) as [] :: EditScript Char Char) `shouldBe` fmap This as
\ as -> (ses (==) as [] :: [Edit Char Char]) `shouldBe` fmap Delete as
prop "returns insertions in That" $
\ bs -> (ses (==) [] bs :: EditScript Char Char) `shouldBe` fmap That bs
\ bs -> (ses (==) [] bs :: [Edit Char Char]) `shouldBe` fmap Insert bs
prop "returns all elements individually for disjoint inputs" $
\ as bs -> length (ses (==) ((,) 0 <$> as :: [(Int, Char)]) ((,) 1 <$> bs :: [(Int, Char)])) `shouldBe` length as + length bs
prop "is lossless w.r.t. both input elements & ordering" $
\ as bs -> foldr (\ each (as, bs) -> these (flip (,) bs. (:as)) ((,) as . (:bs)) (\ a b -> (a:as, b:bs)) each) ([], []) (ses (==) as bs :: EditScript Char Char) `shouldBe` (as, bs)
\ as bs -> foldr (\ each (as, bs) -> these (flip (,) bs. (:as)) ((,) as . (:bs)) (\ a b -> (a:as, b:bs)) (toThese each)) ([], []) (ses (==) as bs :: [Edit Char Char]) `shouldBe` (as, bs)

18
test/Rendering/TOC/Spec.hs
View File

@ -2,6 +2,8 @@
module Rendering.TOC.Spec (spec) where
import Analysis.TOCSummary
import Control.Effect.Parse
import Control.Effect.Reader
import Data.Aeson hiding (defaultOptions)
import Data.Bifunctor
import Data.Diff
@ -15,7 +17,7 @@ import Prelude
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import Rendering.TOC
import Semantic.Api (DiffEffects, decorateTerm, decoratingDiffWith, diffSummaryBuilder, summarizeDiff, summarizeDiffParsers)
import Semantic.Api (DiffEffects, diffSummaryBuilder, summarizeTerms, summarizeDiffParsers)
import Serializing.Format as Format
import Source.Loc
import Source.Span
@ -134,22 +136,22 @@ spec = do
describe "diff with ToCDiffRenderer'" $ do
it "produces JSON output" $ do
blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb"))
output <- runTaskOrDie (diffSummaryBuilder Format.JSON [blobs])
output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.B.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"self.foo\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"ADDED\"},{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":6,\"column\":4}},\"changeType\":\"MODIFIED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}]}]}\n" :: ByteString)
it "produces JSON output if there are parse errors" $ do
blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.X.rb"))
output <- runTaskOrDie (diffSummaryBuilder Format.JSON [blobs])
output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"REMOVED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}],\"errors\":[{\"error\":\"expected end of input nodes, but got ParseError\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":3}}}]}]}\n" :: ByteString)
it "ignores anonymous functions" $ do
blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/lambda.A.rb") (Path.relFile "ruby/toc/lambda.B.rb"))
output <- runTaskOrDie (diffSummaryBuilder Format.JSON [blobs])
output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/lambda.A.rb -> test/fixtures/ruby/toc/lambda.B.rb\",\"language\":\"Ruby\"}]}\n" :: ByteString)
it "summarizes Markdown headings" $ do
blobs <- blobsForPaths (Both (Path.relFile "markdown/toc/headings.A.md") (Path.relFile "markdown/toc/headings.B.md"))
output <- runTaskOrDie (diffSummaryBuilder Format.JSON [blobs])
output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\",\"language\":\"Markdown\",\"changes\":[{\"category\":\"Heading 1\",\"term\":\"Introduction\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":3,\"column\":16}},\"changeType\":\"REMOVED\"},{\"category\":\"Heading 2\",\"term\":\"Two\",\"span\":{\"start\":{\"line\":5,\"column\":1},\"end\":{\"line\":7,\"column\":4}},\"changeType\":\"MODIFIED\"},{\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"span\":{\"start\":{\"line\":9,\"column\":1},\"end\":{\"line\":11,\"column\":10}},\"changeType\":\"ADDED\"},{\"category\":\"Heading 1\",\"term\":\"Final\",\"span\":{\"start\":{\"line\":13,\"column\":1},\"end\":{\"line\":14,\"column\":4}},\"changeType\":\"ADDED\"}]}]}\n" :: ByteString)
@ -163,7 +165,7 @@ numTocSummaries diff = length $ filter isRight (diffTOC diff)
programWithChange :: Term' -> Diff'
programWithChange body = merge (Nothing, Nothing) (inject [ function' ])
where
function' = merge (Just (Declaration Function "foo" mempty lowerBound Ruby), Just (Declaration Function "foo" mempty lowerBound Ruby)) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [ inserting body ]))))
function' = merge (Just (Declaration Function "foo" lowerBound Ruby), Just (Declaration Function "foo" lowerBound Ruby)) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [ inserting body ]))))
name' = merge (Nothing, Nothing) (inject (Syntax.Identifier (name "foo")))
-- Return a diff where term is inserted in the program, below a function found on Both sides of the diff.
@ -187,7 +189,7 @@ programOf :: Diff' -> Diff'
programOf diff = merge (Nothing, Nothing) (inject [ diff ])
functionOf :: Text -> Term' -> Term'
functionOf n body = termIn (Just (Declaration Function n mempty lowerBound Unknown)) (inject (Declaration.Function [] name' [] (termIn Nothing (inject [body]))))
functionOf n body = termIn (Just (Declaration Function n lowerBound Unknown)) (inject (Declaration.Function [] name' [] (termIn Nothing (inject [body]))))
where
name' = termIn Nothing (inject (Syntax.Identifier (name n)))
@ -217,4 +219,4 @@ summarize
:: DiffEffects sig m
=> BlobPair
-> m [Either ErrorSummary TOCSummary]
summarize = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff)
summarize = parsePairWith (summarizeDiffParsers defaultLanguageModes) summarizeTerms

4
test/Semantic/CLI/Spec.hs
View File

@ -69,8 +69,8 @@ diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.
diffFixtures =
[ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json")
, ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt")
, ("toc summaries diff", diffSummaryBuilder Serializing.Format.JSON, pathMode, prefix </> Path.file "diff-tree.toc.json")
, ("protobuf diff", diffSummaryBuilder Serializing.Format.Proto, pathMode, prefix </> Path.file "diff-tree.toc.protobuf.bin")
, ("toc summaries diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.JSON, pathMode, prefix </> Path.file "diff-tree.toc.json")
, ("protobuf diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.Proto, pathMode, prefix </> Path.file "diff-tree.toc.protobuf.bin")
]
where pathMode = [Both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby) (File "test/fixtures/ruby/corpus/method-declaration.B.rb" Ruby)]
prefix = Path.relDir "test/fixtures/cli"

55
test/Tags/Spec.hs
View File

@ -1,9 +1,10 @@
module Tags.Spec (spec) where
import Data.Text (Text)
import Source.Loc
import SpecHelpers
import Tags.Tagging as Tags
import qualified System.Path as Path
import Tags.Tagging as Tags
spec :: Spec
spec = do
@ -11,94 +12,94 @@ spec = do
it "produces tags for functions with docs" $ do
(blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "TestFromBits" Function (Span (Pos 6 1) (Pos 8 2)) "func TestFromBits(t *testing.T) {" (Just "// TestFromBits ...")
, Tag "Hi" Function (Span (Pos 10 1) (Pos 11 2)) "func Hi()" Nothing ]
[ Tag "TestFromBits" Function (Loc (Range 51 92) (Span (Pos 6 1) (Pos 8 2))) "func TestFromBits(t *testing.T) {" (Just "// TestFromBits ...")
, Tag "Hi" Function (Loc (Range 94 107) (Span (Pos 10 1) (Pos 11 2))) "func Hi()" Nothing ]
it "produces tags for methods" $ do
(blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/method.go")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "CheckAuth" Method (Span (Pos 3 1) (Pos 3 100)) "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)" Nothing]
[ Tag "CheckAuth" Method (Loc (Range 19 118) (Span (Pos 3 1) (Pos 3 100))) "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)" Nothing]
it "produces tags for calls" $ do
(blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
runTagging (blobLanguage blob) ["Call"] (blobSource blob) tree `shouldBe`
[ Tag "Hi" Call (Span (Pos 7 2) (Pos 7 6)) "Hi()" Nothing]
[ Tag "Hi" Call (Loc (Range 86 90) (Span (Pos 7 2) (Pos 7 6))) "Hi()" Nothing]
describe "javascript and typescript" $ do
it "produces tags for functions with docs" $ do
(blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/javascript/tags/simple_function_with_docs.js")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "myFunction" Function (Span (Pos 2 1) (Pos 4 2)) "function myFunction()" (Just "// This is myFunction") ]
[ Tag "myFunction" Function (Loc (Range 22 59) (Span (Pos 2 1) (Pos 4 2))) "function myFunction()" (Just "// This is myFunction") ]
it "produces tags for classes" $ do
(blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/class.ts")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "FooBar" Class (Span (Pos 1 1) (Pos 1 16)) "class FooBar" Nothing ]
[ Tag "FooBar" Class (Loc (Range 0 15) (Span (Pos 1 1) (Pos 1 16))) "class FooBar" Nothing ]
it "produces tags for modules" $ do
(blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/module.ts")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "APromise" Tags.Module (Span (Pos 1 1) (Pos 1 20)) "module APromise { }" Nothing ]
[ Tag "APromise" Tags.Module (Loc (Range 0 19) (Span (Pos 1 1) (Pos 1 20))) "module APromise { }" Nothing ]
describe "python" $ do
it "produces tags for functions" $ do
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_functions.py")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "Foo" Function (Span (Pos 1 1) (Pos 5 17)) "def Foo(x):" Nothing
, Tag "Bar" Function (Span (Pos 7 1) (Pos 11 13)) "def Bar():" Nothing
, Tag "local" Function (Span (Pos 8 5) (Pos 9 17)) "def local():" Nothing
[ Tag "Foo" Function (Loc (Range 0 68) (Span (Pos 1 1) (Pos 5 17))) "def Foo(x):" Nothing
, Tag "Bar" Function (Loc (Range 70 136) (Span (Pos 7 1) (Pos 11 13))) "def Bar():" Nothing
, Tag "local" Function (Loc (Range 85 114) (Span (Pos 8 5) (Pos 9 17))) "def local():" Nothing
]
it "produces tags for functions with docs" $ do
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_function_with_docs.py")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x):" (Just "\"\"\"This is the foo function\"\"\"") ]
[ Tag "Foo" Function (Loc (Range 0 59) (Span (Pos 1 1) (Pos 3 13))) "def Foo(x):" (Just "\"\"\"This is the foo function\"\"\"") ]
it "produces tags for classes" $ do
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/class.py")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "Foo" Class (Span (Pos 1 1) (Pos 5 17)) "class Foo:" (Just "\"\"\"The Foo class\"\"\"")
, Tag "f" Function (Span (Pos 3 5) (Pos 5 17)) "def f(self):" (Just "\"\"\"The f method\"\"\"")
[ Tag "Foo" Class (Loc (Range 0 95) (Span (Pos 1 1) (Pos 5 17))) "class Foo:" (Just "\"\"\"The Foo class\"\"\"")
, Tag "f" Function (Loc (Range 39 95) (Span (Pos 3 5) (Pos 5 17))) "def f(self):" (Just "\"\"\"The f method\"\"\"")
]
it "produces tags for multi-line functions" $ do
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/multiline.py")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x," Nothing ]
[ Tag "Foo" Function (Loc (Range 0 29) (Span (Pos 1 1) (Pos 3 13))) "def Foo(x," Nothing ]
describe "ruby" $ do
it "produces tags for methods" $ do
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "foo" Method (Span (Pos 1 1) (Pos 4 4)) "def foo" Nothing ]
[ Tag "foo" Method (Loc (Range 0 31) (Span (Pos 1 1) (Pos 4 4))) "def foo" Nothing ]
it "produces tags for sends" $ do
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
runTagging (blobLanguage blob) ["Send"] (blobSource blob) tree `shouldBe`
[ Tag "puts" Call (Span (Pos 2 3) (Pos 2 12)) "puts \"hi\"" Nothing
, Tag "bar" Call (Span (Pos 3 3) (Pos 3 8)) "a.bar" Nothing
, Tag "a" Call (Span (Pos 3 3) (Pos 3 4)) "a" Nothing
[ Tag "puts" Call (Loc (Range 10 19) (Span (Pos 2 3) (Pos 2 12))) "puts \"hi\"" Nothing
, Tag "bar" Call (Loc (Range 22 27) (Span (Pos 3 3) (Pos 3 8))) "a.bar" Nothing
, Tag "a" Call (Loc (Range 22 23) (Span (Pos 3 3) (Pos 3 4))) "a" Nothing
]
it "produces tags for methods with docs" $ do
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method_with_docs.rb")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "foo" Method (Span (Pos 2 1) (Pos 3 4)) "def foo" (Just "# Public: foo") ]
[ Tag "foo" Method (Loc (Range 14 25) (Span (Pos 2 1) (Pos 3 4))) "def foo" (Just "# Public: foo") ]
it "correctly tags files containing multibyte UTF-8 characters" $ do
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/unicode_identifiers.rb")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "日本語" Method (Span (Pos 2 1) (Pos 4 4)) "def 日本語" (Just "# coding: utf-8")]
[ Tag "日本語" Method (Loc (Range 16 43) (Span (Pos 2 1) (Pos 4 4))) "def 日本語" (Just "# coding: utf-8")]
it "produces tags for methods and classes with docs" $ do
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/class_module.rb")
runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
[ Tag "Foo" Tags.Module (Span (Pos 2 1 ) (Pos 12 4)) "module Foo" (Just "# Public: Foo")
, Tag "Bar" Class (Span (Pos 5 3 ) (Pos 11 6)) "class Bar" (Just "# Public: Bar")
, Tag "baz" Method (Span (Pos 8 5 ) (Pos 10 8)) "def baz(a)" (Just "# Public: baz")
, Tag "C" Class (Span (Pos 14 1) (Pos 20 4)) "class A::B::C" Nothing
, Tag "foo" Method (Span (Pos 15 3) (Pos 17 6)) "def foo" Nothing
, Tag "foo" Method (Span (Pos 18 3) (Pos 19 6)) "def self.foo" Nothing
[ Tag "Foo" Tags.Module (Loc (Range 14 118) (Span (Pos 2 1 ) (Pos 12 4))) "module Foo" (Just "# Public: Foo")
, Tag "Bar" Class (Loc (Range 44 114) (Span (Pos 5 3 ) (Pos 11 6))) "class Bar" (Just "# Public: Bar")
, Tag "baz" Method (Loc (Range 77 108) (Span (Pos 8 5 ) (Pos 10 8))) "def baz(a)" (Just "# Public: baz")
, Tag "C" Class (Loc (Range 120 188) (Span (Pos 14 1) (Pos 20 4))) "class A::B::C" Nothing
, Tag "foo" Method (Loc (Range 136 163) (Span (Pos 15 3) (Pos 17 6))) "def foo" Nothing
, Tag "foo" Method (Loc (Range 166 184) (Span (Pos 18 3) (Pos 19 6))) "def self.foo" Nothing
]
symbolsToSummarize :: [Text]