mirror of
https://github.com/github/semantic.git
synced 2025-01-03 13:02:37 +03:00
Merge branch 'master' into python-assignment
This commit is contained in:
commit
092e3f38f4
@ -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 = 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)]
|
||||
|
14
src/Diff.hs
14
src/Diff.hs
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Diff where
|
||||
|
||||
@ -24,10 +24,9 @@ diffCost :: (Foldable f, Functor f) => Diff f annotation -> Int
|
||||
diffCost = diffSum $ patchSum termSize
|
||||
|
||||
-- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch.
|
||||
mergeMaybe :: forall f annotation. Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation)
|
||||
mergeMaybe :: Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation)
|
||||
mergeMaybe transform extractAnnotation = iter algebra . fmap transform
|
||||
where algebra :: TermF f (Both annotation) (Maybe (Term f annotation)) -> Maybe (Term f annotation)
|
||||
algebra (annotations :< syntax) = cofree . (extractAnnotation annotations :<) <$> sequenceAlt syntax
|
||||
where algebra (annotations :< syntax) = cofree . (extractAnnotation annotations :<) <$> sequenceAlt syntax
|
||||
|
||||
-- | Recover the before state of a diff.
|
||||
beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation)
|
||||
@ -44,13 +43,8 @@ mapAnnotations :: (Functor f, Functor g)
|
||||
=> (annotation -> annotation')
|
||||
-> Free (TermF f (g annotation)) (Patch (Term f annotation))
|
||||
-> Free (TermF f (g annotation')) (Patch (Term f annotation'))
|
||||
mapAnnotations f = iter (\ (h :< functor) -> wrap (fmap f h :< functor)) . fmap (pure . fmap (fmap f))
|
||||
mapAnnotations f = hoistFree (first (fmap f)) . fmap (fmap (fmap f))
|
||||
|
||||
-- | Map a function over the annotations of a single diff node, if it is in Free.
|
||||
modifyAnnotations :: (Functor f, Functor g) => (annotation -> annotation) -> Free (TermF f (g annotation)) a -> Free (TermF f (g annotation)) a
|
||||
modifyAnnotations f r = case runFree r of
|
||||
Free (ga :< functor) -> wrap (fmap f ga :< functor)
|
||||
_ -> r
|
||||
|
||||
instance (NFData (f (Diff f a)), NFData (Cofree f a), NFData a, Functor f) => NFData (Diff f a) where
|
||||
rnf fa = case runFree fa of
|
||||
|
@ -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
|
||||
|
19
src/Patch.hs
19
src/Patch.hs
@ -7,15 +7,14 @@ module Patch
|
||||
, deleting
|
||||
, after
|
||||
, before
|
||||
, afterOrBefore
|
||||
, unPatch
|
||||
, patchSum
|
||||
, maybeFst
|
||||
, maybeSnd
|
||||
, mapPatch
|
||||
, patchType
|
||||
) where
|
||||
|
||||
import Data.Align
|
||||
import Data.Functor.Listable
|
||||
import Data.These
|
||||
import Prologue
|
||||
@ -51,12 +50,6 @@ after = maybeSnd . unPatch
|
||||
before :: Patch a -> Maybe a
|
||||
before = maybeFst . unPatch
|
||||
|
||||
afterOrBefore :: Patch a -> Maybe a
|
||||
afterOrBefore patch = case (before patch, after patch) of
|
||||
(_, Just after) -> Just after
|
||||
(Just before, _) -> Just before
|
||||
(_, _) -> Nothing
|
||||
|
||||
-- | Return both sides of a patch.
|
||||
unPatch :: Patch a -> These a a
|
||||
unPatch (Replace a b) = These a b
|
||||
@ -80,11 +73,6 @@ maybeFst = these Just (const Nothing) ((Just .) . const)
|
||||
maybeSnd :: These a b -> Maybe b
|
||||
maybeSnd = these (const Nothing) Just ((Just .) . flip const)
|
||||
|
||||
patchType :: Patch a -> Text
|
||||
patchType patch = case patch of
|
||||
Replace{} -> "modified"
|
||||
Insert{} -> "added"
|
||||
Delete{} -> "removed"
|
||||
|
||||
-- Instances
|
||||
|
||||
@ -93,3 +81,8 @@ instance Listable1 Patch where
|
||||
|
||||
instance Listable a => Listable (Patch a) where
|
||||
tiers = tiers1
|
||||
|
||||
instance Crosswalk Patch where
|
||||
crosswalk f (Replace a b) = alignWith (these Delete Insert Replace) (f a) (f b)
|
||||
crosswalk f (Insert b) = Insert <$> f b
|
||||
crosswalk f (Delete a) = Delete <$> f a
|
||||
|
@ -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]
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -50,7 +50,7 @@ runDiff DiffArguments{..} = do
|
||||
blobs <- runCommand $ case diffMode of
|
||||
DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b)
|
||||
DiffCommits sha1 sha2 paths -> readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
|
||||
Semantic.diffBlobPairs diffRenderer blobs
|
||||
Semantic.diffBlobPairs termDecorator diffRenderer blobs
|
||||
|
||||
runParse :: ParseArguments -> IO ByteString
|
||||
runParse ParseArguments{..} = do
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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")) ])
|
||||
|
@ -7,7 +7,6 @@ import Test.Hspec.Expectations.Pretty
|
||||
import Language
|
||||
import Syntax
|
||||
import Renderer
|
||||
import Renderer.SExpression
|
||||
import Source
|
||||
|
||||
spec :: Spec
|
||||
|
@ -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
|
||||
|
@ -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
137
test/TOCSpec.hs
@ -1,13 +1,14 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DataKinds, TypeOperators #-}
|
||||
module TOCSpec where
|
||||
|
||||
import Data.Aeson
|
||||
import Category as C
|
||||
import Data.Functor.Both
|
||||
import Data.Functor.Listable
|
||||
import RWS
|
||||
import Data.Record
|
||||
import Data.String
|
||||
import Data.Text.Listable
|
||||
import Data.These
|
||||
import Diff
|
||||
import Info
|
||||
import Interpreter
|
||||
@ -16,11 +17,12 @@ import Patch
|
||||
import Prologue hiding (fst, snd, readFile)
|
||||
import Renderer
|
||||
import Renderer.TOC
|
||||
import RWS
|
||||
import Semantic
|
||||
import Source
|
||||
import SpecHelpers
|
||||
import Syntax as S
|
||||
import Term
|
||||
import Semantic
|
||||
import SpecHelpers
|
||||
import Test.Hspec (Spec, describe, it, parallel)
|
||||
import Test.Hspec.Expectations.Pretty
|
||||
import Test.Hspec.LeanCheck
|
||||
@ -28,46 +30,67 @@ import Test.LeanCheck
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "tableOfContentsBy" $ do
|
||||
prop "drops all nodes with the constant Nothing function" $
|
||||
\ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (unListableDiff diff :: Diff (Syntax ()) ()) `shouldBe` []
|
||||
|
||||
let diffSize = max 1 . sum . fmap (const 1)
|
||||
let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a))
|
||||
prop "includes all nodes with a constant Just function" $
|
||||
\ diff -> let diff' = (unListableDiff diff :: Diff (Syntax ()) ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') ()
|
||||
|
||||
prop "produces an unchanged entry for identity diffs" $
|
||||
\ term -> let term' = (unListableF term :: Term (Syntax ()) (Record '[Category])) in tableOfContentsBy (Just . headF) (diffTerms term' term') `shouldBe` [Unchanged (lastValue term')]
|
||||
|
||||
prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $
|
||||
\ patch -> let patch' = (unListableF <$> patch :: Patch (Term (Syntax ()) Int)) in tableOfContentsBy (Just . headF) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch'))
|
||||
|
||||
prop "produces changed entries for relevant nodes containing irrelevant patches" $
|
||||
\ diff -> let diff' = fmap (1 <$) <$> mapAnnotations (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff (Syntax ()) Int])) in
|
||||
tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe`
|
||||
if Prologue.null diff' then [Unchanged 0]
|
||||
else replicate (Prologue.length diff') (Changed 0)
|
||||
|
||||
describe "diffTOC" $ do
|
||||
it "blank if there are no methods" $
|
||||
diffTOC blankDiffBlobs blankDiff `shouldBe` [ ]
|
||||
diffTOC blankDiff `shouldBe` [ ]
|
||||
|
||||
it "summarizes changed methods" $ do
|
||||
sourceBlobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
|
||||
Just diff <- diffBlobPair sourceBlobs
|
||||
diffTOC sourceBlobs diff `shouldBe`
|
||||
Just diff <- diffBlobPair declarationDecorator sourceBlobs
|
||||
diffTOC diff `shouldBe`
|
||||
[ JSONSummary $ Summarizable C.SingletonMethod "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added"
|
||||
, JSONSummary $ InSummarizable C.Method "bar" (sourceSpanBetween (4, 1) (6, 4))
|
||||
, JSONSummary $ Summarizable C.Method "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified"
|
||||
, JSONSummary $ Summarizable C.Method "baz" (sourceSpanBetween (4, 1) (5, 4)) "removed" ]
|
||||
|
||||
it "dedupes changes in same parent method" $ do
|
||||
sourceBlobs <- blobsForPaths (both "javascript/duplicate-parent.A.js" "javascript/duplicate-parent.B.js")
|
||||
Just diff <- diffBlobPair sourceBlobs
|
||||
diffTOC sourceBlobs diff `shouldBe`
|
||||
[ JSONSummary $ InSummarizable C.Function "myFunction" (sourceSpanBetween (1, 1) (6, 2)) ]
|
||||
Just diff <- diffBlobPair declarationDecorator sourceBlobs
|
||||
diffTOC diff `shouldBe`
|
||||
[ JSONSummary $ Summarizable C.Function "myFunction" (sourceSpanBetween (1, 1) (6, 2)) "modified" ]
|
||||
|
||||
it "dedupes similar methods" $ do
|
||||
sourceBlobs <- blobsForPaths (both "javascript/erroneous-duplicate-method.A.js" "javascript/erroneous-duplicate-method.B.js")
|
||||
Just diff <- diffBlobPair sourceBlobs
|
||||
diffTOC sourceBlobs diff `shouldBe`
|
||||
Just diff <- diffBlobPair declarationDecorator sourceBlobs
|
||||
diffTOC diff `shouldBe`
|
||||
[ JSONSummary $ Summarizable C.Function "performHealthCheck" (sourceSpanBetween (8, 1) (29, 2)) "modified" ]
|
||||
|
||||
it "summarizes Go methods with receivers with special formatting" $ do
|
||||
sourceBlobs <- blobsForPaths (both "go/method-with-receiver.A.go" "go/method-with-receiver.B.go")
|
||||
Just diff <- diffBlobPair sourceBlobs
|
||||
diffTOC sourceBlobs diff `shouldBe`
|
||||
Just diff <- diffBlobPair declarationDecorator sourceBlobs
|
||||
diffTOC diff `shouldBe`
|
||||
[ JSONSummary $ Summarizable C.Method "(*apiClient) CheckAuth" (sourceSpanBetween (3,1) (3,101)) "added" ]
|
||||
|
||||
it "summarizes Ruby methods that start with two identifiers" $ do
|
||||
sourceBlobs <- blobsForPaths (both "ruby/method-starts-with-two-identifiers.A.rb" "ruby/method-starts-with-two-identifiers.B.rb")
|
||||
Just diff <- diffBlobPair sourceBlobs
|
||||
diffTOC sourceBlobs diff `shouldBe`
|
||||
[ JSONSummary $ InSummarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) ]
|
||||
Just diff <- diffBlobPair declarationDecorator sourceBlobs
|
||||
diffTOC diff `shouldBe`
|
||||
[ JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" ]
|
||||
|
||||
it "handles unicode characters in file" $ do
|
||||
sourceBlobs <- blobsForPaths (both "ruby/unicode.A.rb" "ruby/unicode.B.rb")
|
||||
Just diff <- diffBlobPair sourceBlobs
|
||||
diffTOC sourceBlobs diff `shouldBe`
|
||||
Just diff <- diffBlobPair declarationDecorator sourceBlobs
|
||||
diffTOC diff `shouldBe`
|
||||
[ JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (6, 1) (7, 4)) "added" ]
|
||||
|
||||
prop "inserts of methods and functions are summarized" $
|
||||
@ -97,11 +120,11 @@ spec = parallel $ do
|
||||
|
||||
prop "equal terms produce identity diffs" $
|
||||
\a -> let term = defaultFeatureVectorDecorator (Info.category . headF) (unListableF a :: Term') in
|
||||
diffTOC blankDiffBlobs (diffTerms term term) `shouldBe` []
|
||||
diffTOC (diffTerms term term) `shouldBe` []
|
||||
|
||||
describe "JSONSummary" $ do
|
||||
it "encodes InSummarizable to JSON" $ do
|
||||
let summary = JSONSummary $ InSummarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4))
|
||||
let summary = JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified"
|
||||
encode summary `shouldBe` "{\"span\":{\"start\":[1,1],\"end\":[4,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"modified\"}"
|
||||
|
||||
it "encodes Summarizable to JSON" $ do
|
||||
@ -111,60 +134,60 @@ spec = parallel $ do
|
||||
describe "diff with ToCRenderer" $ do
|
||||
it "produces JSON output" $ do
|
||||
blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
|
||||
output <- diffBlobPairs ToCRenderer [blobs]
|
||||
output <- diffBlobPairs declarationDecorator ToCRenderer [blobs]
|
||||
output `shouldBe` "{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n"
|
||||
|
||||
it "produces JSON output if there are parse errors" $ do
|
||||
blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.X.rb")
|
||||
output <- diffBlobPairs ToCRenderer [blobs]
|
||||
output `shouldBe` "{\"changes\":{},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\"}]}}\n"
|
||||
output <- diffBlobPairs declarationDecorator ToCRenderer [blobs]
|
||||
output `shouldBe` "{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\"}]}}\n"
|
||||
|
||||
type Diff' = SyntaxDiff String DefaultFields
|
||||
type Term' = SyntaxTerm String DefaultFields
|
||||
type Diff' = SyntaxDiff Text (Maybe Declaration ': DefaultFields)
|
||||
type Term' = SyntaxTerm Text (Maybe Declaration ': DefaultFields)
|
||||
|
||||
numTocSummaries :: Diff' -> Int
|
||||
numTocSummaries diff = Prologue.length $ filter (not . isErrorSummary) (diffTOC blankDiffBlobs diff)
|
||||
numTocSummaries diff = Prologue.length $ filter isValidSummary (diffTOC diff)
|
||||
|
||||
-- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff.
|
||||
programWithChange :: Term' -> Diff'
|
||||
programWithChange body = free $ Free (pure programInfo :< Indexed [ function' ])
|
||||
programWithChange body = wrap (pure programInfo :< Indexed [ function' ])
|
||||
where
|
||||
function' = free $ Free (pure functionInfo :< S.Function name' [] [ free $ Pure (Insert body) ] )
|
||||
name' = free $ Free (pure (Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo")
|
||||
function' = wrap (pure (Just (FunctionDeclaration "foo") :. functionInfo) :< S.Function name' [] [ inserting body ] )
|
||||
name' = wrap (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo")
|
||||
|
||||
-- Return a diff where term is inserted in the program, below a function found on both sides of the diff.
|
||||
programWithChangeOutsideFunction :: Term' -> Diff'
|
||||
programWithChangeOutsideFunction term = free $ Free (pure programInfo :< Indexed [ function', term' ])
|
||||
programWithChangeOutsideFunction term = wrap (pure programInfo :< Indexed [ function', term' ])
|
||||
where
|
||||
function' = free $ Free (pure functionInfo :< S.Function name' [] [] )
|
||||
name' = free $ Free (pure (Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo")
|
||||
term' = free $ Pure (Insert term)
|
||||
function' = wrap (pure (Just (FunctionDeclaration "foo") :. functionInfo) :< S.Function name' [] [] )
|
||||
name' = wrap (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo")
|
||||
term' = inserting term
|
||||
|
||||
programWithInsert :: String -> Term' -> Diff'
|
||||
programWithInsert name body = programOf $ Insert (functionOf name body)
|
||||
programWithInsert :: Text -> Term' -> Diff'
|
||||
programWithInsert name body = programOf $ inserting (functionOf name body)
|
||||
|
||||
programWithDelete :: String -> Term' -> Diff'
|
||||
programWithDelete name body = programOf $ Delete (functionOf name body)
|
||||
programWithDelete :: Text -> Term' -> Diff'
|
||||
programWithDelete name body = programOf $ deleting (functionOf name body)
|
||||
|
||||
programWithReplace :: String -> Term' -> Diff'
|
||||
programWithReplace name body = programOf $ Replace (functionOf name body) (functionOf (name <> "2") body)
|
||||
programWithReplace :: Text -> Term' -> Diff'
|
||||
programWithReplace name body = programOf $ replacing (functionOf name body) (functionOf (name <> "2") body)
|
||||
|
||||
programOf :: Patch Term' -> Diff'
|
||||
programOf patch = free $ Free (pure programInfo :< Indexed [ free $ Pure patch ])
|
||||
programOf :: Diff' -> Diff'
|
||||
programOf diff = wrap (pure programInfo :< Indexed [ diff ])
|
||||
|
||||
functionOf :: String -> Term' -> Term'
|
||||
functionOf name body = cofree $ functionInfo :< S.Function name' [] [body]
|
||||
functionOf :: Text -> Term' -> Term'
|
||||
functionOf name body = cofree $ (Just (FunctionDeclaration name) :. functionInfo) :< S.Function name' [] [body]
|
||||
where
|
||||
name' = cofree $ (Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name
|
||||
name' = cofree $ (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name
|
||||
|
||||
programInfo :: Record DefaultFields
|
||||
programInfo = Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil
|
||||
programInfo :: Record (Maybe Declaration ': DefaultFields)
|
||||
programInfo = Nothing :. Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil
|
||||
|
||||
functionInfo :: Record DefaultFields
|
||||
functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil
|
||||
|
||||
-- Filter tiers for terms that we consider "meaniningful" in TOC summaries.
|
||||
isMeaningfulTerm :: ListableF (Term (Syntax leaf)) (Record DefaultFields) -> Bool
|
||||
isMeaningfulTerm :: ListableF (Term (Syntax leaf)) a -> Bool
|
||||
isMeaningfulTerm a = case runCofree (unListableF a) of
|
||||
(_ :< S.Indexed _) -> False
|
||||
(_ :< S.Fixed _) -> False
|
||||
@ -173,7 +196,7 @@ isMeaningfulTerm a = case runCofree (unListableF a) of
|
||||
_ -> True
|
||||
|
||||
-- Filter tiers for terms if the Syntax is a Method or a Function.
|
||||
isMethodOrFunction :: ListableF (Term (Syntax leaf)) (Record DefaultFields) -> Bool
|
||||
isMethodOrFunction :: HasField fields Category => ListableF (Term (Syntax leaf)) (Record fields) -> Bool
|
||||
isMethodOrFunction a = case runCofree (unListableF a) of
|
||||
(_ :< S.Method{}) -> True
|
||||
(_ :< S.Function{}) -> True
|
||||
@ -188,14 +211,14 @@ blobsForPaths = traverse (readFile . ("test/fixtures/toc/" <>))
|
||||
sourceSpanBetween :: (Int, Int) -> (Int, Int) -> SourceSpan
|
||||
sourceSpanBetween (s1, e1) (s2, e2) = SourceSpan (SourcePos s1 e1) (SourcePos s2 e2)
|
||||
|
||||
blankDiff :: Diff (Syntax Text) (Record '[Category, Range, SourceSpan])
|
||||
blankDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "\"a\"")) ])
|
||||
blankDiff :: Diff'
|
||||
blankDiff = wrap (pure arrayInfo :< Indexed [ inserting (cofree $ literalInfo :< Leaf "\"a\"") ])
|
||||
where
|
||||
arrayInfo = ArrayLiteral :. Range 0 3 :. sourceSpanBetween (1, 1) (1, 5) :. Nil
|
||||
literalInfo = StringLiteral :. Range 1 2 :. sourceSpanBetween (1, 2) (1, 4) :. Nil
|
||||
arrayInfo = Nothing :. Range 0 3 :. ArrayLiteral :. sourceSpanBetween (1, 1) (1, 5) :. Nil
|
||||
literalInfo = Nothing :. Range 1 2 :. StringLiteral :. sourceSpanBetween (1, 2) (1, 4) :. Nil
|
||||
|
||||
blankDiffBlobs :: Both SourceBlob
|
||||
blankDiffBlobs = both (SourceBlob (fromText "[]") nullOid "a.js" (Just defaultPlainBlob) (Just JavaScript)) (SourceBlob (fromText "[a]") nullOid "b.js" (Just defaultPlainBlob) (Just JavaScript))
|
||||
|
||||
unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation
|
||||
unListableDiff diff = hoistFree (first unListableF) $ fmap unListableF <$> unListableF diff
|
||||
instance Listable Text where
|
||||
tiers = unListableText `mapT` tiers
|
||||
|
Loading…
Reference in New Issue
Block a user