1
1
mirror of https://github.com/github/semantic.git synced 2024-12-23 06:41:45 +03:00
semantic/src/DiffSummary.hs

241 lines
13 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-}
2016-06-07 02:41:07 +03:00
2016-07-30 01:37:41 +03:00
module DiffSummary (DiffSummary(..), diffSummaries, DiffInfo(..), annotatedSummaries) where
2016-04-25 18:46:10 +03:00
2016-06-28 23:38:06 +03:00
import Prologue hiding (snd, intercalate)
2016-04-25 18:46:10 +03:00
import Diff
import Patch
2016-05-17 22:59:07 +03:00
import Term
2016-07-29 21:05:11 +03:00
import Info (category, characterRange)
import Range
2016-07-25 21:55:30 +03:00
import Syntax as S
import Category as C
2016-05-03 19:17:38 +03:00
import Data.Functor.Foldable as Foldable
2016-05-18 00:34:27 +03:00
import Data.Functor.Both
import Data.Text as Text (intercalate)
import Test.QuickCheck hiding (Fixed)
import Patch.Arbitrary()
import Data.Record
import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string, Doc, punctuate, pretty)
import qualified Text.PrettyPrint.Leijen.Text as P
import SourceSpan
2016-07-29 19:59:07 +03:00
import Source
2016-04-25 18:46:10 +03:00
data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text }
| BranchInfo { branches :: [ DiffInfo ], categoryName :: Text, branchType :: Branch }
| ErrorInfo { errorSpan :: SourceSpan, categoryName :: Text }
deriving (Eq, Show)
2016-05-18 17:18:26 +03:00
toTermName :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term leaf (Record fields) -> Text
2016-07-29 20:12:36 +03:00
toTermName source term = case unwrap term of
2016-07-25 21:55:30 +03:00
S.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children
S.Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children
2016-06-15 18:06:13 +03:00
Leaf leaf -> toCategoryName leaf
2016-07-29 20:12:36 +03:00
S.Assignment identifier value -> toTermName' identifier <> toTermName' value
S.Function identifier _ _ -> (maybe "anonymous" toTermName' identifier)
S.FunctionCall i _ -> toTermName' i
2016-07-25 21:55:30 +03:00
S.MemberAccess base property -> case (unwrap base, unwrap property) of
2016-07-29 20:12:36 +03:00
(S.FunctionCall{}, S.FunctionCall{}) -> toTermName' base <> "()." <> toTermName' property <> "()"
(S.FunctionCall{}, _) -> toTermName' base <> "()." <> toTermName' property
(_, S.FunctionCall{}) -> toTermName' base <> "." <> toTermName' property <> "()"
(_, _) -> toTermName' base <> "." <> toTermName' property
S.MethodCall targetId methodId _ -> toTermName' targetId <> sep <> toTermName' methodId <> "()"
where sep = case unwrap targetId of
2016-07-25 21:55:30 +03:00
S.FunctionCall{} -> "()."
_ -> "."
2016-07-25 21:55:30 +03:00
S.SubscriptAccess base element -> case (unwrap base, unwrap element) of
2016-07-29 20:12:36 +03:00
(S.FunctionCall{}, S.FunctionCall{}) -> toTermName' base <> "()." <> toTermName' element <> "()"
2016-07-29 20:49:07 +03:00
(S.FunctionCall{}, _) -> toTermName' base <> "()." <> toTermName' element
2016-07-29 20:12:36 +03:00
(_, S.FunctionCall{}) -> toTermName' base <> "[" <> toTermName' element <> "()" <> "]"
(_, _) -> toTermName' base <> "[" <> toTermName' element <> "]"
S.VarAssignment varId _ -> toTermName' varId
S.VarDecl decl -> toTermName' decl
2016-06-16 01:51:17 +03:00
-- TODO: We should remove Args from Syntax since I don't think we should ever
2016-06-15 21:15:09 +03:00
-- evaluate Args as a single toTermName Text - joshvera
2016-07-29 20:12:36 +03:00
S.Args args -> mconcat $ toTermName' <$> args
2016-06-16 01:51:17 +03:00
-- TODO: We should remove Case from Syntax since I don't think we should ever
-- evaluate Case as a single toTermName Text - joshvera
2016-07-29 20:12:36 +03:00
S.Case expr _ -> toTermName' expr
S.Switch expr _ -> toTermName' expr
S.Ternary expr _ -> toTermName' expr
S.MathAssignment id _ -> toTermName' id
S.Operator _ -> termNameFromSource term
2016-07-29 20:12:36 +03:00
S.Object kvs -> "{" <> intercalate ", " (toTermName' <$> kvs) <> "}"
S.Pair a b -> toTermName' a <> ": " <> toTermName' b
S.Return expr -> maybe "empty" toTermName' expr
2016-08-04 17:02:39 +03:00
S.Error span _ -> displayStartEndPos span
S.For exprs _ -> termNameFromChildren term exprs
2016-07-29 20:12:36 +03:00
S.While expr _ -> toTermName' expr
S.DoWhile _ expr -> toTermName' expr
S.Throw expr -> toText $ Source.slice (characterRange $ extract expr) source
2016-07-30 21:26:01 +03:00
S.Constructor expr -> toTermName' expr
2016-07-29 23:02:25 +03:00
S.Try expr _ _ -> toText $ Source.slice (characterRange $ extract expr) source
2016-07-29 23:46:04 +03:00
S.Array _ -> toText $ Source.slice (characterRange $ extract term) source
2016-07-29 23:32:52 +03:00
S.Class identifier _ _ -> toTermName' identifier
2016-07-30 21:00:47 +03:00
S.Method identifier _ _ -> toTermName' identifier
2016-07-11 19:55:32 +03:00
Comment a -> toCategoryName a
S.Commented _ wrapped -> maybe "anonymous" toTermName' wrapped
2016-07-29 20:12:36 +03:00
where toTermName' = toTermName source
termNameFromChildren term cs = termNameFromRange (unionRangesFrom (range term) (range <$> cs))
termNameFromSource term = termNameFromRange (range term)
termNameFromRange range = toText $ Source.slice range source
range = characterRange . extract
2016-05-24 19:49:16 +03:00
class HasCategory a where
toCategoryName :: a -> Text
2016-05-18 00:34:27 +03:00
2016-05-24 19:49:16 +03:00
instance HasCategory Text where
toCategoryName = identity
2016-05-18 19:01:16 +03:00
2016-05-24 19:49:16 +03:00
instance HasCategory Category where
2016-06-10 22:24:37 +03:00
toCategoryName = \case
2016-06-15 18:06:13 +03:00
ArrayLiteral -> "array"
2016-05-18 00:34:27 +03:00
BinaryOperator -> "binary operator"
2016-06-16 17:54:20 +03:00
Boolean -> "boolean"
2016-05-18 20:37:02 +03:00
DictionaryLiteral -> "dictionary"
2016-07-25 21:55:30 +03:00
C.Error -> "error"
2016-06-10 22:24:37 +03:00
ExpressionStatements -> "expression statements"
2016-07-25 21:55:30 +03:00
C.Assignment -> "assignment"
C.Function -> "function"
C.FunctionCall -> "function call"
C.MemberAccess -> "member access"
C.MethodCall -> "method call"
C.Args -> "arguments"
C.VarAssignment -> "var assignment"
C.VarDecl -> "variable"
C.Switch -> "switch statement"
C.Case -> "case statement"
C.SubscriptAccess -> "subscript access"
C.MathAssignment -> "math assignment"
C.Ternary -> "ternary"
C.Operator -> "operator"
2016-06-15 18:06:13 +03:00
Identifier -> "identifier"
IntegerLiteral -> "integer"
Other s -> s
2016-07-25 21:55:30 +03:00
C.Pair -> "pair"
2016-06-15 18:06:13 +03:00
Params -> "params"
Program -> "top level"
Regex -> "regex"
2016-06-15 18:06:13 +03:00
StringLiteral -> "string"
SymbolLiteral -> "symbol"
2016-06-15 18:39:18 +03:00
TemplateString -> "template string"
C.For -> "for statement"
C.While -> "while statement"
C.DoWhile -> "do/while statement"
2016-07-25 21:55:30 +03:00
C.Object -> "object"
2016-07-29 18:48:31 +03:00
C.Return -> "return statement"
2016-07-29 22:35:28 +03:00
C.Throw -> "throw statement"
C.Constructor -> "constructor"
C.Catch -> "catch statement"
C.Try -> "try statement"
C.Finally -> "finally statement"
C.Class -> "class"
C.Method -> "method"
2016-05-17 20:09:14 +03:00
instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where
toCategoryName = toCategoryName . category . extract
2016-05-24 19:49:16 +03:00
2016-07-27 19:28:37 +03:00
data Branch = BIndexed | BFixed | BCommented deriving (Show, Eq, Generic)
instance Arbitrary Branch where
arbitrary = oneof [ pure BIndexed, pure BFixed ]
shrink = genericShrink
2016-05-17 20:09:14 +03:00
data DiffSummary a = DiffSummary {
patch :: Patch a,
parentAnnotations :: [Category]
} deriving (Eq, Functor, Show, Generic)
instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where
arbitrary = DiffSummary <$> arbitrary <*> arbitrary
shrink = genericShrink
2016-05-13 18:44:03 +03:00
instance P.Pretty DiffInfo where
pretty LeafInfo{..} = squotes (string $ toSL termName) <+> (string $ toSL categoryName)
pretty BranchInfo{..} = mconcat $ punctuate (string "," <> space) (pretty <$> branches)
2016-07-28 01:23:52 +03:00
pretty ErrorInfo{..} = "syntax error at" <+> (string . toSL $ displayStartEndPos errorSpan) <+> "in" <+> (string . toSL $ spanName errorSpan)
annotatedSummaries :: DiffSummary DiffInfo -> [Text]
annotatedSummaries DiffSummary{..} = show . (P.<> maybeParentContext parentAnnotations) <$> summaries patch
summaries :: Patch DiffInfo -> [P.Doc]
summaries (Insert info) = (("Added" <+> "the") <+>) <$> toLeafInfos info
summaries (Delete info) = (("Deleted" <+> "the") <+>) <$> toLeafInfos info
summaries (Replace i1 i2) = zipWith (\a b -> "Replaced" <+> "the" <+> a <+> "with the" <+> b) (toLeafInfos i1) (toLeafInfos i2)
toLeafInfos :: DiffInfo -> [Doc]
2016-07-27 19:28:37 +03:00
toLeafInfos LeafInfo{..} = pure $ squotes (toDoc termName) <+> (toDoc categoryName)
toLeafInfos BranchInfo{..} = pretty <$> branches
2016-07-27 19:28:37 +03:00
toLeafInfos err@ErrorInfo{} = pure $ pretty err
maybeParentContext :: [Category] -> Doc
maybeParentContext annotations = if null annotations
then ""
else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context"
toDoc :: Text -> Doc
toDoc = string . toS
2016-04-25 18:46:10 +03:00
2016-07-30 01:37:41 +03:00
diffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [DiffSummary DiffInfo]
diffSummaries sources = cata $ \case
-- Skip comments and leaves since they don't have any changes
(Free (_ :< Leaf _)) -> []
2016-07-25 21:55:30 +03:00
Free (_ :< (S.Comment _)) -> []
2016-07-29 20:49:07 +03:00
(Free (infos :< S.Indexed children)) -> annotateWithCategory infos <$> join children
(Free (infos :< S.Fixed children)) -> annotateWithCategory infos <$> join children
(Free (infos :< S.FunctionCall identifier children)) -> annotateWithCategory infos <$> join (Prologue.toList (identifier : children))
(Free (infos :< S.Function id ps body)) -> annotateWithCategory infos <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body
(Free (infos :< S.Assignment id value)) -> annotateWithCategory infos <$> id <> value
(Free (infos :< S.MemberAccess base property)) -> annotateWithCategory infos <$> base <> property
(Free (infos :< S.SubscriptAccess base property)) -> annotateWithCategory infos <$> base <> property
(Free (infos :< S.MethodCall targetId methodId ps)) -> annotateWithCategory infos <$> targetId <> methodId <> ps
(Free (infos :< S.VarAssignment varId value)) -> annotateWithCategory infos <$> varId <> value
(Free (infos :< S.VarDecl decl)) -> annotateWithCategory infos <$> decl
(Free (infos :< S.Args args)) -> annotateWithCategory infos <$> join args
(Free (infos :< S.Switch expr cases)) -> annotateWithCategory infos <$> expr <> join cases
(Free (infos :< S.Case expr body)) -> annotateWithCategory infos <$> expr <> body
Free (infos :< (S.Ternary expr cases)) -> annotateWithCategory infos <$> expr <> join cases
Free (infos :< (S.MathAssignment id value)) -> annotateWithCategory infos <$> id <> value
Free (infos :< (S.Operator syntaxes)) -> annotateWithCategory infos <$> join syntaxes
Free (infos :< (S.Object kvs)) -> annotateWithCategory infos <$> join kvs
Free (infos :< (S.Return expr)) -> annotateWithCategory infos <$> fromMaybe [] expr
Free (infos :< (S.Pair a b)) -> annotateWithCategory infos <$> a <> b
Free (infos :< (S.Commented cs leaf)) -> annotateWithCategory infos <$> join cs <> fromMaybe [] leaf
2016-07-29 21:05:11 +03:00
Free (infos :< (S.Error _ children)) -> annotateWithCategory infos <$> join children
2016-07-29 20:49:07 +03:00
(Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body
(Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body
(Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body
2016-07-29 22:35:28 +03:00
(Free (infos :< S.Throw expr)) -> annotateWithCategory infos <$> expr
2016-07-30 21:26:21 +03:00
(Free (infos :< S.Constructor expr)) -> annotateWithCategory infos <$> expr
2016-07-29 23:03:06 +03:00
(Free (infos :< S.Try expr catch finally)) -> annotateWithCategory infos <$> expr <> fromMaybe [] catch <> fromMaybe [] finally
2016-07-29 23:47:08 +03:00
(Free (infos :< S.Array children)) -> annotateWithCategory infos <$> join children
(Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> fromMaybe [] superclass <> join definitions
2016-07-30 20:47:30 +03:00
(Free (infos :< S.Method identifier params definitions)) -> annotateWithCategory infos <$> identifier <> join params <> join definitions
2016-07-29 20:49:07 +03:00
(Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ]
(Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ]
(Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ]
where
(beforeSource, afterSource) = runJoin sources
2016-07-29 20:49:07 +03:00
annotateWithCategory infos = prependSummary (category $ snd infos)
2016-07-29 21:12:44 +03:00
termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term leaf (Record fields) -> DiffInfo
2016-07-29 20:49:07 +03:00
termToDiffInfo blob term = case unwrap term of
Leaf _ -> LeafInfo (toCategoryName term) (toTermName' term)
S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BIndexed
S.Fixed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BFixed
S.FunctionCall identifier _ -> LeafInfo (toCategoryName term) (toTermName' identifier)
S.Ternary ternaryCondition _ -> LeafInfo (toCategoryName term) (toTermName' ternaryCondition)
S.Function identifier _ _ -> LeafInfo (toCategoryName term) (maybe "anonymous" toTermName' identifier)
S.Assignment identifier _ -> LeafInfo (toCategoryName term) (toTermName' identifier)
S.MathAssignment identifier _ -> LeafInfo (toCategoryName term) (toTermName' identifier)
-- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to
-- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value
-- to indicate where that value should be when constructing DiffInfos.
2016-07-29 20:49:07 +03:00
Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (toCategoryName term) BCommented
2016-07-29 21:05:11 +03:00
S.Error sourceSpan _ -> ErrorInfo sourceSpan (toCategoryName term)
2016-07-29 20:49:07 +03:00
_ -> LeafInfo (toCategoryName term) (toTermName' term)
where toTermName' = toTermName blob
termToDiffInfo' = termToDiffInfo blob
2016-05-16 17:54:05 +03:00
prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo
2016-05-16 17:54:05 +03:00
prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary }