diff --git a/src/Category.hs b/src/Category.hs index e6de322a8..491af79bb 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -79,6 +79,18 @@ data Category | Return -- | A throw statement. | Throw + -- | A constructor statement, e.g. new Foo; + | Constructor + -- | A try statement. + | Try + -- | A catch statement. + | Catch + -- | A finally statement. + | Finally + -- | A class declaration. + | Class + -- | A class method declaration. + | Method -- | A non-standard category, which can be used for comparability. | Other Text deriving (Eq, Generic, Ord, Show) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index e34433814..ccc0edff5 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-} -module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..), annotatedSummaries) where +module DiffSummary (DiffSummary(..), diffSummaries, DiffInfo(..), annotatedSummaries) where import Prologue hiding (snd, intercalate) import Diff @@ -59,18 +59,25 @@ toTermName source term = case unwrap term of S.Switch expr _ -> toTermName' expr S.Ternary expr _ -> toTermName' expr S.MathAssignment id _ -> toTermName' id - S.Operator syntaxes -> mconcat $ toTermName' <$> syntaxes + S.Operator _ -> termNameFromSource term S.Object kvs -> "{" <> intercalate ", " (toTermName' <$> kvs) <> "}" S.Pair a b -> toTermName' a <> ": " <> toTermName' b S.Return expr -> maybe "empty" toTermName' expr - S.For exprs _ -> toText $ Source.slice (unionRangesFrom forRange forClauseRanges) source - where forRange = characterRange $ extract term - forClauseRanges = characterRange . extract <$> exprs + S.For exprs _ -> termNameFromChildren term exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr S.Throw expr -> toText $ Source.slice (characterRange $ extract expr) source + S.Constructor expr -> toTermName' expr + S.Try expr _ _ -> toText $ Source.slice (characterRange $ extract expr) source + S.Array _ -> toText $ Source.slice (characterRange $ extract term) source + S.Class identifier _ _ -> toTermName' identifier + S.Method identifier _ _ -> toTermName' identifier Comment a -> toCategoryName a 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 class HasCategory a where toCategoryName :: a -> Text @@ -116,6 +123,12 @@ instance HasCategory Category where C.Object -> "object" C.Return -> "return statement" 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" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract @@ -159,8 +172,8 @@ maybeParentContext annotations = if null annotations toDoc :: Text -> Doc toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] -diffSummary sources = cata $ \case +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 _)) -> [] Free (_ :< (S.Comment _)) -> [] @@ -189,6 +202,11 @@ diffSummary sources = cata $ \case (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.Throw expr)) -> annotateWithCategory infos <$> expr + (Free (infos :< S.Constructor expr)) -> annotateWithCategory infos <$> expr + (Free (infos :< S.Try expr catch finally)) -> annotateWithCategory infos <$> expr <> fromMaybe [] catch <> fromMaybe [] finally + (Free (infos :< S.Array children)) -> annotateWithCategory infos <$> join children + (Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> fromMaybe [] superclass <> join definitions + (Free (infos :< S.Method identifier params definitions)) -> annotateWithCategory infos <$> identifier <> join params <> join definitions (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)) [] ] @@ -210,7 +228,6 @@ termToDiffInfo blob term = case unwrap term of -- 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. - S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (toCategoryName term) BCommented S.Error sourceSpan _ -> ErrorInfo sourceSpan (toCategoryName term) _ -> LeafInfo (toCategoryName term) (toTermName' term) diff --git a/src/Parser.hs b/src/Parser.hs index 54a4a7e4f..875a9cc30 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -17,13 +17,9 @@ import SourceSpan -- | and aren't pure. type Parser fields = SourceBlob -> IO (Term Text (Record fields)) --- | Categories that are treated as fixed nodes. -fixedCategories :: Set.Set Category -fixedCategories = Set.fromList [ BinaryOperator, Pair ] - --- | Should these categories be treated as fixed nodes? -isFixed :: Category -> Bool -isFixed = flip Set.member fixedCategories +-- | Whether a category is an Operator Category +isOperator :: Category -> Bool +isOperator = flip Set.member (Set.fromList [ Operator, BinaryOperator ]) -- | Given a function that maps production names to sets of categories, produce -- | a Constructor. @@ -49,7 +45,7 @@ termConstructor source sourceSpan info = cofree . construct construct children | SubscriptAccess == category info = case children of (base:element:[]) -> withDefaultInfo $ S.SubscriptAccess base element _ -> withDefaultInfo $ S.Error sourceSpan children - construct children | Operator == category info = withDefaultInfo $ S.Operator children + construct children | isOperator (category info) = withDefaultInfo $ S.Operator children construct children | Function == category info = case children of (body:[]) -> withDefaultInfo $ S.Function Nothing Nothing body (params:body:[]) | (info :< _) <- runCofree params, Params == category info -> @@ -92,7 +88,7 @@ termConstructor source sourceSpan info = cofree . construct toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] toTuple child = pure child - construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children + construct children | Pair == (category info) = withDefaultInfo $ S.Fixed children construct children | C.Error == category info = withDefaultInfo $ S.Error sourceSpan children construct children | For == category info, Just (exprs, body) <- unsnoc children = @@ -103,5 +99,46 @@ termConstructor source sourceSpan info = cofree . construct withDefaultInfo $ S.DoWhile expr body construct children | Throw == category info, [expr] <- children = withDefaultInfo $ S.Throw expr + construct children | Constructor == category info, [expr] <- children = + withDefaultInfo $ S.Constructor expr + construct children | Try == category info = case children of + [body] -> withDefaultInfo $ S.Try body Nothing Nothing + [body, catch] | Catch <- category (extract catch) -> withDefaultInfo $ S.Try body (Just catch) Nothing + [body, finally] | Finally <- category (extract finally) -> withDefaultInfo $ S.Try body Nothing (Just finally) + [body, catch, finally] | Catch <- category (extract catch), + Finally <- category (extract finally) -> + withDefaultInfo $ S.Try body (Just catch) (Just finally) + _ -> withDefaultInfo $ S.Error sourceSpan children + construct children | ArrayLiteral == category info = + withDefaultInfo $ S.Array children + construct children | Method == category info = case children of + [identifier, params, exprs] | + Params == category (extract params), + S.Indexed params' <- unwrap params, + exprs' <- expressionStatements exprs -> + withDefaultInfo $ S.Method identifier params' exprs' + [identifier, exprs] | exprs' <- expressionStatements exprs -> + withDefaultInfo $ S.Method identifier mempty exprs' + _ -> + withDefaultInfo $ S.Error sourceSpan children + construct children | Class == category info = case children of + [identifier, superclass, definitions] | definitions' <- methodDefinitions definitions -> + withDefaultInfo $ S.Class identifier (Just superclass) definitions' + [identifier, definitions] | definitions' <- methodDefinitions definitions -> + withDefaultInfo $ S.Class identifier Nothing definitions' + _ -> + withDefaultInfo $ S.Error sourceSpan children construct children = withDefaultInfo $ S.Indexed children + +expressionStatements :: HasField fields Category => Term Text (Record fields) -> [Term Text (Record fields)] +expressionStatements exprs | + Other "statement_block" == category (extract exprs), + S.Indexed exprs' <- unwrap exprs = exprs' +expressionStatements _ = mempty + +methodDefinitions :: HasField fields Category => Term Text (Record fields) -> [Term Text (Record fields)] +methodDefinitions definitions | + Other "class_body" == category (extract definitions), + S.Indexed definitions' <- unwrap definitions = definitions' +methodDefinitions _ = mempty \ No newline at end of file diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 84039592a..e44a31278 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -7,7 +7,7 @@ module Renderer.JSON ( import Prologue hiding (toList) import Alignment import Category -import Data.Aeson hiding (json) +import Data.Aeson as A hiding (json) import Data.Bifunctor.Join import Data.ByteString.Builder import Data.Record @@ -35,13 +35,13 @@ instance ToJSON Category where toJSON (Other s) = String s toJSON s = String . T.pack $ show s instance ToJSON Range where - toJSON (Range start end) = Array . fromList $ toJSON <$> [ start, end ] + toJSON (Range start end) = A.Array . fromList $ toJSON <$> [ start, end ] toEncoding (Range start end) = foldable [ start, end ] instance ToJSON a => ToJSON (Join These a) where - toJSON (Join vs) = Array . fromList $ toJSON <$> these pure pure (\ a b -> [ a, b ]) vs + toJSON (Join vs) = A.Array . fromList $ toJSON <$> these pure pure (\ a b -> [ a, b ]) vs toEncoding = foldable instance ToJSON a => ToJSON (Join (,) a) where - toJSON (Join (a, b)) = Array . fromList $ toJSON <$> [ a, b ] + toJSON (Join (a, b)) = A.Array . fromList $ toJSON <$> [ a, b ] toEncoding = foldable instance (HasField fields Category, HasField fields Range) => ToJSON (SplitDiff leaf (Record fields)) where toJSON splitDiff = case runFree splitDiff of @@ -85,11 +85,16 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.SubscriptAccess id property -> [ "subscriptId" .= id ] <> [ "property" .= property ] S.Object pairs -> childrenFields pairs S.Pair a b -> childrenFields [a, b] - S.Return expr -> [ "returnExpr" .= expr ] + S.Return expr -> [ "returnExpression" .= expr ] + S.Constructor expr -> [ "constructorExpression" .= expr ] S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c S.Throw c -> [ "throwExpression" .= c ] + S.Try body catch finally -> [ "tryBody" .= body ] <> [ "tryCatch" .= catch ] <> [ "tryFinally" .= finally ] + S.Array c -> childrenFields c + S.Class identifier superclass definitions -> [ "classIdentifier" .= identifier ] <> [ "superclass" .= superclass ] <> [ "definitions" .= definitions ] + S.Method identifier params definitions -> [ "methodIdentifier" .= identifier ] <> [ "params" .= params ] <> [ "definitions" .= definitions ] where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 8c88719c9..151655678 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -40,7 +40,6 @@ styleName category = "category-" <> case category of StringLiteral -> "string" SymbolLiteral -> "symbol" IntegerLiteral -> "integer" - ArrayLiteral -> "array" C.FunctionCall -> "function_call" C.Function -> "function" C.MethodCall -> "method_call" @@ -66,6 +65,12 @@ styleName category = "category-" <> case category of C.DoWhile -> "do_while" C.Return -> "return_statement" C.Throw -> "throw_statement" + C.Constructor -> "constructor" + C.Try -> "try_statement" + C.Catch -> "catch_statement" + C.Finally -> "finally_statement" + ArrayLiteral -> "array" + C.Class -> "class_statement" Other string -> string -- | Pick the class name for a split patch. diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 1969da4af..68bed1987 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -11,4 +11,4 @@ import Source summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) summary blobs diff = toS . encode $ summaries >>= annotatedSummaries - where summaries = diffSummary (source <$> blobs) diff \ No newline at end of file + where summaries = diffSummaries (source <$> blobs) diff \ No newline at end of file diff --git a/src/Syntax.hs b/src/Syntax.hs index e0a76d99f..b5b6e39ed 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -61,11 +61,24 @@ data Syntax | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) | Throw f + | Constructor f + | Try f (Maybe f) (Maybe f) + -- | An array literal with list of children. + | Array [f] + -- | A class with an identifier, superclass, and a list of definitions. + | Class f (Maybe f) [f] + -- | A method definition with an identifier, params, and a list of expressions. + | Method f [f] [f] deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) -- Instances +instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where + arbitrary = sized (syntaxOfSize (`resize` arbitrary) ) + + shrink = genericShrink + syntaxOfSize :: Arbitrary leaf => (Int -> Gen f) -> Int -> Gen (Syntax leaf f) syntaxOfSize recur n | n <= 1 = oneof $ (Leaf <$> arbitrary) : branchGeneratorsOfSize n | otherwise = oneof $ branchGeneratorsOfSize n @@ -79,8 +92,3 @@ syntaxOfSize recur n | n <= 1 = oneof $ (Leaf <$> arbitrary) : branchGeneratorsO first <- recur m rest <- childrenOfSize (n - m) pure $! first : rest - -instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where - arbitrary = sized (syntaxOfSize (`resize` arbitrary) ) - - shrink = genericShrink diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 7d14d539a..91cb4540c 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -30,19 +30,26 @@ treeSitterParser language grammar blob = do categoriesForLanguage :: Language -> Text -> Category categoriesForLanguage language name = case (language, name) of (JavaScript, "object") -> Object - (JavaScript, "rel_op") -> BinaryOperator -- relational operator, e.g. >, <, <=, >=, ==, != - (JavaScript, "bool_op") -> BinaryOperator (JavaScript, "expression_statement") -> ExpressionStatements (JavaScript, "this_expression") -> Identifier (JavaScript, "null") -> Identifier (JavaScript, "undefined") -> Identifier (JavaScript, "arrow_function") -> Function (JavaScript, "generator_function") -> Function - (JavaScript, "delete_op") -> Operator - (JavaScript, "type_op") -> Operator - (JavaScript, "void_op") -> Operator + (JavaScript, "math_op") -> BinaryOperator -- bitwise operator, e.g. +, -, *, /. + (JavaScript, "bool_op") -> BinaryOperator -- boolean operator, e.g. ||, &&. + (JavaScript, "bitwise_op") -> BinaryOperator -- bitwise operator, e.g. ^, &, etc. + (JavaScript, "rel_op") -> BinaryOperator -- relational operator, e.g. >, <, <=, >=, ==, !=. + (JavaScript, "comma_op") -> Operator -- comma operator, e.g. expr1, expr2. + (JavaScript, "delete_op") -> Operator -- delete operator, e.g. delete x[2]. + (JavaScript, "type_op") -> Operator -- type operator, e.g. typeof Object. + (JavaScript, "void_op") -> Operator -- void operator, e.g. void 2. (JavaScript, "for_in_statement") -> For (JavaScript, "for_of_statement") -> For + (JavaScript, "new_expression") -> Constructor + (JavaScript, "class") -> Class + (JavaScript, "catch") -> Catch + (JavaScript, "finally") -> Finally (Ruby, "hash") -> Object _ -> defaultCategoryForNodeName name @@ -82,6 +89,8 @@ defaultCategoryForNodeName name = case name of "do_statement" -> DoWhile "return_statement" -> Return "throw_statement" -> Throw + "try_statement" -> Try + "method_definition" -> Method _ -> Other name -- | Return a parser for a tree sitter language & document. diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index dfc01e535..dc648c4bf 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -41,13 +41,13 @@ sources = both (fromText "[]") (fromText "[a]") spec :: Spec spec = parallel $ do - describe "diffSummary" $ do + describe "diffSummaries" $ do it "outputs a diff summary" $ do - diffSummary sources testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] + diffSummaries sources testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] prop "equal terms produce identity diffs" $ \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category, Range])) in - diffSummary sources (diffTerms wrap (==) diffCost term term) `shouldBe` [] + diffSummaries sources (diffTerms wrap (==) diffCost term term) `shouldBe` [] describe "annotatedSummaries" $ do it "should print adds" $ @@ -58,7 +58,7 @@ spec = parallel $ do prop "patches in summaries match the patches in diffs" $ \a -> let diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost, Range]))) - summaries = diffSummary sources diff + summaries = diffSummaries sources diff patches = toList diff in case (partition isBranchNode (patch <$> summaries), partition isIndexedOrFixed patches) of @@ -67,7 +67,7 @@ spec = parallel $ do prop "generates one LeafInfo for each child in an arbitrary branch patch" $ \a -> let diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Range]))) - diffInfoPatches = patch <$> diffSummary sources diff + diffInfoPatches = patch <$> diffSummaries sources diff syntaxPatches = toList diff extractLeaves :: DiffInfo -> [DiffInfo] extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children