Merge pull request #242 from github/tree-sitter-ffi

Tree sitter FFI

.gitignore

@@ -5,3 +5,4 @@ xcuserdata
 *.xcuserdatad
 *.xccheckout
 .stack-work
+libbridge.dylib

.gitmodules

@@ -13,9 +13,9 @@
 [submodule "prototype/External/tree-sitter"]
 	path = prototype/External/tree-sitter
 	url = https://github.com/maxbrunsfeld/tree-sitter.git
-[submodule "prototype/External/node-tree-sitter-javascript"]
+[submodule "prototype/External/tree-sitter-javascript"]
 	path = prototype/External/tree-sitter-javascript
-	url = https://github.com/maxbrunsfeld/node-tree-sitter-javascript.git
+	url = https://github.com/maxbrunsfeld/tree-sitter-javascript.git
 [submodule "prototype/External/tree-sitter-c"]
 	path = prototype/External/tree-sitter-c
-	url = https://github.com/maxbrunsfeld/tree-sitter-c.git
+	url = https://github.com/robrix/tree-sitter-c.git

app/Main.hs

@@ -5,28 +5,108 @@ import Patch
 import Term
 import Syntax
 import Control.Comonad.Cofree
-import Control.Monad.Free
-import Data.Map
+import Control.Monad.Free hiding (unfoldM)
+import qualified Data.Map as Map
 import Data.Maybe
 import Data.Set
-import Language.Haskell.Parser
-import Language.Haskell.Syntax
 import System.Environment
 
+import Foreign
+import Foreign.C
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.ForeignPtr.Unsafe
+
+data TSLanguage = TsLanguage deriving (Show, Eq)
+foreign import ccall "prototype/doubt-difftool/doubt-difftool-Bridging-Header.h ts_language_c" ts_language_c :: IO (Ptr TSLanguage)
+
+data TSDocument = TsDocument deriving (Show, Eq)
+foreign import ccall "prototype/External/tree-sitter/include/tree_sitter/runtime.h ts_document_make" ts_document_make :: IO (Ptr TSDocument)
+foreign import ccall "prototype/External/tree-sitter/include/tree_sitter/runtime.h ts_document_set_language" ts_document_set_language :: Ptr TSDocument -> Ptr TSLanguage -> IO ()
+foreign import ccall "prototype/External/tree-sitter/include/tree_sitter/runtime.h ts_document_set_input_string" ts_document_set_input_string :: Ptr TSDocument -> CString -> IO ()
+foreign import ccall "prototype/External/tree-sitter/include/tree_sitter/runtime.h ts_document_parse" ts_document_parse :: Ptr TSDocument -> IO ()
+foreign import ccall "prototype/External/tree-sitter/include/tree_sitter/runtime.h ts_document_free" ts_document_free :: Ptr TSDocument -> IO ()
+
+data TSLength = TsLength { bytes :: CSize, chars :: CSize }
+  deriving (Show, Eq)
+
+data TSNode = TsNode { _data :: Ptr (), offset :: TSLength }
+  deriving (Show, Eq)
+
+instance Storable TSNode where
+  alignment n = 24
+  sizeOf n = 24
+  peek p = error "Haskell code should never read TSNode values directly."
+  poke p n = error "Haskell code should never write TSNode values directly."
+
+foreign import ccall "app/bridge.h ts_document_root_node_p" ts_document_root_node_p :: Ptr TSDocument -> Ptr TSNode -> IO ()
+foreign import ccall "app/bridge.h ts_node_p_name" ts_node_p_name :: Ptr TSNode -> Ptr TSDocument -> IO CString
+foreign import ccall "app/bridge.h ts_node_p_named_child_count" ts_node_p_named_child_count :: Ptr TSNode -> IO CSize
+foreign import ccall "app/bridge.h ts_node_p_named_child" ts_node_p_named_child :: Ptr TSNode -> CSize -> Ptr TSNode -> IO CSize
+foreign import ccall "app/bridge.h ts_node_p_pos_chars" ts_node_p_pos_chars :: Ptr TSNode -> IO CSize
+foreign import ccall "app/bridge.h ts_node_p_size_chars" ts_node_p_size_chars :: Ptr TSNode -> IO CSize
 
 main :: IO ()
 main = do
   args <- getArgs
   let (a, b) = files args in do
-    a' <- parseModuleFile a
-    b' <- parseModuleFile b
+    a' <- parseTreeSitterFile a
+    b' <- parseTreeSitterFile b
     return (a', b')
   return ()
 
-parseModuleFile :: FilePath -> IO (ParseResult HsModule)
-parseModuleFile file = do
+parseTreeSitterFile :: FilePath -> IO (Term String Info)
+parseTreeSitterFile file = do
+  document <- ts_document_make
+  language <- ts_language_c
+  ts_document_set_language document language
   contents <- readFile file
-  return $ parseModule contents
+  withCString contents (\source -> do
+    ts_document_set_input_string document source
+    ts_document_parse document
+    term <- documentToTerm document contents
+    ts_document_free document
+    return term)
+
+documentToTerm :: Ptr TSDocument -> String -> IO (Term String Info)
+documentToTerm document contents = alloca $ \root -> do
+  ts_document_root_node_p document root
+  snd <$> toTerm root where
+    toTerm :: Ptr TSNode -> IO (String, Term String Info)
+    toTerm node = do
+      name <- ts_node_p_name node document
+      name <- peekCString name
+      children <- withNamedChildren node toTerm
+      range <- range node
+      annotation <- return . Info range $ singleton name
+      return (name, annotation :< case children of
+        [] -> Leaf $ substring range contents
+        _ | member name keyedProductions -> Keyed $ Map.fromList children
+        _ | member name fixedProductions -> Fixed $ fmap snd children
+        _ | otherwise -> Indexed $ fmap snd children)
+
+keyedProductions = fromList [ "object" ]
+fixedProductions = fromList [ "pair", "rel_op", "math_op", "bool_op", "bitwise_op", "type_op", "math_assignment", "assignment", "subscript_access", "member_access", "new_expression", "function_call", "function", "ternary" ]
+
+withNamedChildren :: Ptr TSNode -> (Ptr TSNode -> IO (String, a)) -> IO [(String, a)]
+withNamedChildren node transformNode = do
+  count <- ts_node_p_named_child_count node
+  if count == 0
+    then return []
+    else mapM (alloca . getChild) [0..pred count] where
+      getChild n out = do
+        ts_node_p_named_child node n out
+        transformNode out
+
+range :: Ptr TSNode -> IO Range
+range node = do
+  pos <- ts_node_p_pos_chars node
+  size <- ts_node_p_size_chars node
+  return Range { start = fromEnum $ toInteger pos, end = (fromEnum $ toInteger pos) + (fromEnum $ toInteger size) }
 
 files (a : as) = (a, file as) where
   file (a : as) = a
+files [] = error "expected two files to diff"
+
+substring :: Range -> String -> String
+substring range = take (end range) . drop (start range)

app/bridge.c

@@ -0,0 +1,52 @@
+#include "bridge.h"
+#include <assert.h>
+#include <stdio.h>
+
+void ts_document_root_node_p(TSDocument *document, TSNode *outNode) {
+	assert(document != NULL);
+	assert(outNode != NULL);
+	*outNode = ts_document_root_node(document);
+}
+
+TSLanguage *ts_language_c_use() {
+	return ts_language_c();
+}
+
+const char *ts_node_p_name(const TSNode *node, const TSDocument *document) {
+	assert(node != NULL);
+	assert(node->data != NULL);
+	assert(document != NULL);
+	return ts_node_name(*node, document);
+}
+
+
+size_t ts_node_p_named_child_count(const TSNode *node) {
+	assert(node != NULL);
+	assert(node->data != NULL);
+	return ts_node_named_child_count(*node);
+}
+
+void ts_node_p_named_child(const TSNode *node, size_t index, TSNode *outNode) {
+	assert(node != NULL);
+	assert(node->data != NULL);
+	assert(outNode != NULL);
+	TSNode temp = ts_node_named_child(*node, index);
+	if (temp.data == NULL) {
+		printf("got broken child for index %ld\n", index);
+	}
+	assert(temp.data != NULL);
+	*outNode = temp;
+}
+
+
+size_t ts_node_p_pos_chars(const TSNode *node) {
+	assert(node != NULL);
+	assert(node->data != NULL);
+	return ts_node_pos(*node).chars;
+}
+
+size_t ts_node_p_size_chars(const TSNode *node) {
+	assert(node != NULL);
+	assert(node->data != NULL);
+	return ts_node_size(*node).chars;
+}

app/bridge.h

@@ -0,0 +1,13 @@
+#include "tree_sitter/runtime.h"
+
+extern TSLanguage *ts_language_c();
+
+void ts_document_root_node_p(TSDocument *document, TSNode *outNode);
+
+const char *ts_node_p_name(const TSNode *node, const TSDocument *document);
+
+size_t ts_node_p_named_child_count(const TSNode *node);
+void ts_node_p_named_child(const TSNode *node, size_t index, TSNode *outNode);
+
+size_t ts_node_p_pos_chars(const TSNode *node);
+size_t ts_node_p_size_chars(const TSNode *node);

prototype/External/tree-sitter

@@ -1 +1 @@
-Subproject commit 1829b34c6f72ed890310b8d523e861f950fb0687
+Subproject commit ce27c2ee97238fdacdefadf56434f14fd080a094

prototype/External/tree-sitter-c

@@ -1 +1 @@
-Subproject commit 3204b80fa7f1284c992b1c6991bc22843f6057e1
+Subproject commit 4dc638b4ac708d80a7c41eee5388c51177b6544f

semantic-diff.cabal

@@ -28,7 +28,7 @@ library
                      , containers
                      , free
   default-language:    Haskell2010
-  default-extensions: DeriveFunctor, FlexibleInstances
+  default-extensions: DeriveFunctor, FlexibleInstances, DeriveFoldable, DeriveTraversable
 
 executable semantic-diff-exe
   hs-source-dirs:      app
@@ -38,8 +38,9 @@ executable semantic-diff-exe
                      , containers
                      , free
                      , semantic-diff
-                     , haskell-src
   default-language:    Haskell2010
+  extra-libraries: bridge
+  extra-lib-dirs: prototype/External/tree-sitter/out/Release, prototype/External/tree-sitter-c, .
 
 test-suite semantic-diff-test
   type:                exitcode-stdio-1.0

src/Syntax.hs

@@ -7,4 +7,4 @@ data Syntax a f =
   | Indexed [f]
   | Fixed [f]
   | Keyed (Map String f)
-  deriving (Functor, Show, Eq)
+  deriving (Functor, Show, Eq, Foldable, Traversable)