Merge remote-tracking branch 'origin/master' into throw-syntax

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)

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)

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

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]

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.

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
+  where summaries = diffSummaries (source <$> blobs) diff

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

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.

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