From e2d90c0a45314b456aa3f533f57a4d6f919dda63 Mon Sep 17 00:00:00 2001 From: Gaute Berge Date: Fri, 11 Sep 2020 13:55:54 +0200 Subject: [PATCH 1/7] Queries working --- tree-sitter-haskell/examples/Demo.hs | 90 +++++++++++-------- tree-sitter-haskell/examples/QueryDemo.hs | 50 +++++++++++ tree-sitter-haskell/tree-sitter-haskell.cabal | 16 +++- tree-sitter/src/TreeSitter/Node.hs | 68 +++----------- tree-sitter/src/TreeSitter/Query.hs | 89 ++++++++++++++++++ tree-sitter/src/TreeSitter/Struct.hs | 64 +++++++++++++ tree-sitter/src/bridge.c | 60 ++++++++----- tree-sitter/test/TreeSitter/Example.hs | 68 +++++++++----- tree-sitter/tree-sitter.cabal | 2 + 9 files changed, 369 insertions(+), 138 deletions(-) create mode 100644 tree-sitter-haskell/examples/QueryDemo.hs create mode 100644 tree-sitter/src/TreeSitter/Query.hs create mode 100644 tree-sitter/src/TreeSitter/Struct.hs diff --git a/tree-sitter-haskell/examples/Demo.hs b/tree-sitter-haskell/examples/Demo.hs index a6d6f199..0c7c9023 100644 --- a/tree-sitter-haskell/examples/Demo.hs +++ b/tree-sitter-haskell/examples/Demo.hs @@ -1,80 +1,96 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Main where +module Main (main) where +import qualified Data.Tree as Tree import TreeSitter.Parser import TreeSitter.Tree -import TreeSitter.Language +import TreeSitter.Query +-- import TreeSitter.Language import TreeSitter.Haskell import TreeSitter.Node import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr ( Ptr(..) +import Foreign.Ptr ( Ptr , nullPtr - , plusPtr - ) -import Foreign.Marshal.Alloc ( malloc - , mallocBytes ) +import Foreign.Marshal.Alloc ( malloc) import Foreign.Marshal.Array ( mallocArray ) import Foreign.Storable ( peek , peekElemOff , poke ) -import Foreign.Marshal.Utils ( new ) import Control.Monad - main :: IO () main = do parser <- ts_parser_new - ts_parser_set_language parser tree_sitter_haskell + _ <- ts_parser_set_language parser tree_sitter_haskell + let source = "module Test (main) where\nimport Lib\nf1 = undefined" + -- "module Test (main) where\nimport Lib\nf1 = undefined\nf2 = undefined" - let source = - "module Test (main) where\nimport Lib\nf1 = undefined\nf2 = undefined" + (str, len) <- newCStringLen source + tree <- ts_parser_parse_string parser nullPtr str len + nodePointer <- malloc + ts_tree_root_node_p tree nodePointer + node <- peek nodePointer + print =<< nodeString node + -- ast <- toAst node + -- print ast - (str, len) <- newCStringLen source - tree <- ts_parser_parse_string parser nullPtr str len + let source = "(function_body) @f" + (str, len) <- newCStringLen source + errorOffset <- malloc + errorType <- malloc + cursor <- ts_query_cursor_new + query <- ts_query_new tree_sitter_haskell str len errorOffset errorType + ts_query_cursor_exec_p cursor query nodePointer + matchPointer <- malloc - n <- malloc - ts_tree_root_node_p tree n + success <- ts_query_cursor_next_match cursor matchPointer + print $ "success: " ++ show success + match <- (peek matchPointer) + capture <- peek $ captures match + print capture - print "module (root) ------------" - n@Node {..} <- peek n - let childCount = fromIntegral nodeChildCount + ts_node <- malloc + poke ts_node (captureTSNode capture) + ts_node_string_p ts_node >>= peekCString >>= print + success <- ts_query_cursor_next_match cursor matchPointer + print $ "success: " ++ show success + +type Ast = Tree.Tree Node' +data Node' = Node' {type_::String, text :: String} deriving Show + +toAst :: Node -> IO Ast +toAst Node {..} = do + -- Node {..} <- peek n + theType <- peekCString nodeType + let childCount = fromIntegral nodeChildCount children <- mallocArray childCount tsNode <- malloc - poke tsNode nodeTSNode + poke tsNode nodeTSNode ts_node_copy_child_nodes tsNode children + text <- ts_node_string_p tsNode >>= peekCString + children' <- forM [0 .. childCount - 1] $ \n -> do + child <- peekElemOff children n + toAst child - printChildren children childCount - - print "where ------------" - n@Node {..} <- peekElemOff children 3 - let nextChildCount = fromIntegral nodeChildCount - - nextChildren <- mallocArray nextChildCount - nextTsNode <- malloc - poke nextTsNode nodeTSNode - ts_node_copy_child_nodes nextTsNode nextChildren - - printChildren nextChildren nextChildCount + return $ Tree.Node (Node' theType text) children' - print "END" printChildren :: Ptr Node -> Int -> IO () printChildren children count = forM_ [0 .. count - 1] - (\n -> do + ( \n -> do child <- peekElemOff children n printNode child ) printNode :: Node -> IO () -printNode Node {..} = do +printNode n@Node {..} = do theType <- peekCString nodeType - let TSPoint {..} = nodeStartPoint + let TSPoint {..} = nodeStartPoint n start = "(" ++ show pointRow ++ "," ++ show pointColumn ++ ")" let TSPoint {..} = nodeEndPoint end = "(" ++ show pointRow ++ "," ++ show pointColumn ++ ")" diff --git a/tree-sitter-haskell/examples/QueryDemo.hs b/tree-sitter-haskell/examples/QueryDemo.hs new file mode 100644 index 00000000..628c3217 --- /dev/null +++ b/tree-sitter-haskell/examples/QueryDemo.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import TreeSitter.Parser +import TreeSitter.Tree +import TreeSitter.Query +import TreeSitter.Haskell +import TreeSitter.Node +import Foreign.C.String +import Foreign.Ptr ( nullPtr) +import Foreign.Marshal.Alloc ( malloc) +import Foreign.Storable ( peek + , poke + ) + +main :: IO () +main = do + parser <- ts_parser_new + _ <- ts_parser_set_language parser tree_sitter_haskell + let source = "module Test (main) where\nimport Lib\nf1 = undefined" + + (str, len) <- newCStringLen source + tree <- ts_parser_parse_string parser nullPtr str len + nodePointer <- malloc + ts_tree_root_node_p tree nodePointer + + let source = "(function_body) @f" + (str, len) <- newCStringLen source + errorOffset <- malloc + errorType <- malloc + cursor <- ts_query_cursor_new + query <- ts_query_new tree_sitter_haskell str len errorOffset errorType + ts_query_cursor_exec_p cursor query nodePointer + matchPointer <- malloc + + success <- ts_query_cursor_next_match cursor matchPointer + print $ "success: " ++ show success + match <- (peek matchPointer) + capture <- peek $ captures match + print capture + + -- print the match + ts_node <- malloc + poke ts_node (captureTSNode capture) + ts_node_string_p ts_node >>= peekCString >>= print + + success <- ts_query_cursor_next_match cursor matchPointer + print $ "success: " ++ show success + diff --git a/tree-sitter-haskell/tree-sitter-haskell.cabal b/tree-sitter-haskell/tree-sitter-haskell.cabal index ac1d94b8..cf0d6699 100644 --- a/tree-sitter-haskell/tree-sitter-haskell.cabal +++ b/tree-sitter-haskell/tree-sitter-haskell.cabal @@ -36,7 +36,20 @@ common common flag build-examples description: Build tree-sitter-haskell examples. - default: False + default: True + +executable query-demo + import: common + main-is: QueryDemo.hs + if !flag(build-examples) + buildable: False + hs-source-dirs: examples + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , containers + , tree-sitter + , tree-sitter-haskell executable demo import: common @@ -47,6 +60,7 @@ executable demo ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base + , containers , tree-sitter , tree-sitter-haskell diff --git a/tree-sitter/src/TreeSitter/Node.hs b/tree-sitter/src/TreeSitter/Node.hs index fec620aa..19fa0723 100644 --- a/tree-sitter/src/TreeSitter/Node.hs +++ b/tree-sitter/src/TreeSitter/Node.hs @@ -4,17 +4,20 @@ module TreeSitter.Node ( Node(..) , nodeStartPoint , nodeStartByte +, nodeString , TSPoint(..) , TSNode(..) , FieldId(..) , ts_node_copy_child_nodes , ts_node_poke_p +, ts_node_string_p ) where import Foreign import Foreign.C import GHC.Generics import TreeSitter.Symbol (TSSymbol) +import TreeSitter.Struct data Node = Node { nodeTSNode :: !TSNode @@ -29,6 +32,12 @@ data Node = Node } deriving (Show, Eq, Generic) +nodeString :: Node -> IO String +nodeString node = do + ts_node <- malloc + poke ts_node $ nodeTSNode node + ts_node_string_p ts_node >>= peekCString + nodeStartPoint :: Node -> TSPoint nodeStartPoint node = let TSNode _ p _ _ _ = nodeTSNode node in p @@ -44,29 +53,6 @@ data TSNode = TSNode !Word32 !TSPoint !Word32 !(Ptr ()) !(Ptr ()) newtype FieldId = FieldId { getFieldId :: Word16 } deriving (Eq, Ord, Show, Storable) - --- | 'Struct' is a strict 'Monad' with automatic alignment & advancing, & inferred type. -newtype Struct a = Struct { runStruct :: forall b . Ptr b -> IO (a, Ptr a) } - -evalStruct :: Struct a -> Ptr b -> IO a -evalStruct s p = fmap fst $! runStruct s p -{-# INLINE evalStruct #-} - -peekStruct :: forall a . Storable a => Struct a -peekStruct = Struct (\ p -> do - let aligned = alignPtr (castPtr p) (alignment (undefined :: a)) - a <- peek aligned - pure (a, aligned `plusPtr` sizeOf a)) -{-# INLINE peekStruct #-} - -pokeStruct :: Storable a => a -> Struct () -pokeStruct a = Struct (\ p -> do - let aligned = alignPtr (castPtr p) (alignment a) - poke aligned a - pure ((), castPtr aligned `plusPtr` sizeOf a)) -{-# INLINE pokeStruct #-} - - instance Storable Node where alignment _ = alignment (undefined :: TSNode) {-# INLINE alignment #-} @@ -126,41 +112,7 @@ instance Storable TSNode where pokeStruct p2 {-# INLINE poke #-} -instance Functor Struct where - fmap f a = Struct go where - go p = do - (a', p') <- runStruct a p - let fa = f a' - fa `seq` p' `seq` pure (fa, castPtr p') - {-# INLINE go #-} - {-# INLINE fmap #-} - -instance Applicative Struct where - pure a = Struct (\ p -> pure (a, castPtr p)) - {-# INLINE pure #-} - - f <*> a = Struct go where - go p = do - (f', p') <- runStruct f p - (a', p'') <- p' `seq` runStruct a (castPtr p') - let fa = f' a' - fa `seq` p'' `seq` pure (fa, castPtr p'') - {-# INLINE go #-} - {-# INLINE (<*>) #-} - -instance Monad Struct where - return = pure - {-# INLINE return #-} - - a >>= f = Struct go where - go p = do - (a', p') <- runStruct a p - (fa', p'') <- p' `seq` runStruct (f a') (castPtr p') - fa' `seq` p'' `seq` pure (fa', p'') - {-# INLINE go #-} - {-# INLINE (>>=) #-} - - foreign import ccall unsafe "src/bridge.c ts_node_copy_child_nodes" ts_node_copy_child_nodes :: Ptr TSNode -> Ptr Node -> IO () -- NB: this leaves the field name as NULL. foreign import ccall unsafe "src/bridge.c ts_node_poke_p" ts_node_poke_p :: Ptr TSNode -> Ptr Node -> IO () +foreign import ccall unsafe "src/bridge.c ts_node_string_p" ts_node_string_p :: Ptr TSNode -> IO CString diff --git a/tree-sitter/src/TreeSitter/Query.hs b/tree-sitter/src/TreeSitter/Query.hs new file mode 100644 index 00000000..daad9fdd --- /dev/null +++ b/tree-sitter/src/TreeSitter/Query.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, RankNTypes, + ScopedTypeVariables, TypeOperators, DeriveAnyClass #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module TreeSitter.Query + ( TSQuery + , TSQueryCursor + , pattern_index + , captures + , captureTSNode + , ts_query_new + , ts_query_cursor_exec_p + , ts_query_cursor_new + , ts_query_cursor_next_match + ) where + +import Foreign +import Foreign.C (CString) +import GHC.Generics +import TreeSitter.Language +import TreeSitter.Node +import TreeSitter.Struct + +data TSQuery + +data TSQueryCursor + +type TSQueryError = Int +-- TODO: Need help implementing storable +-- data TSQueryError = TSQueryErrorNone | TSQueryErrorSyntax | TSQueryErrorNodeType | TSQueryErrorField | TSQueryErrorCapture +-- deriving (Show, Enum) + +data TSQueryCapture = TSQueryCapture + { captureTSNode :: !TSNode + , index :: !Word32 + } deriving (Show, Eq, Generic) + +data TSQueryMatch = TSQueryMatch + { id :: !Word32 + , pattern_index :: !Word16 + , capture_count :: !Word16 + , captures :: Ptr TSQueryCapture + } deriving (Show, Eq, Generic) + +instance Storable TSQueryMatch where + alignment _ = alignment (0 :: Int32) + {-# INLINE alignment #-} + sizeOf _ = 80 + {-# INLINE sizeOf #-} + peek = + evalStruct $ + TSQueryMatch <$> peekStruct <*> peekStruct <*> peekStruct <*> peekStruct + {-# INLINE peek #-} + poke ptr (TSQueryMatch a b c d) = + flip evalStruct ptr $ do + pokeStruct a + pokeStruct b + pokeStruct c + pokeStruct d + {-# INLINE poke #-} + +instance Storable TSQueryCapture where + alignment _ = alignment (0 :: Int32) + {-# INLINE alignment #-} + sizeOf _ = 8 + {-# INLINE sizeOf #-} + peek = evalStruct $ TSQueryCapture <$> peekStruct <*> peekStruct + {-# INLINE peek #-} + poke ptr (TSQueryCapture a b) = + flip evalStruct ptr $ do + pokeStruct a + pokeStruct b + {-# INLINE poke #-} + +foreign import ccall safe "ts_query_new" ts_query_new :: + Ptr Language -> + CString -> + Int -> Ptr Word32 -> Ptr TSQueryError -> IO (Ptr TSQuery) + +foreign import ccall safe "ts_query_cursor_new" ts_query_cursor_new + :: IO (Ptr TSQueryCursor) + +foreign import ccall safe "src/bridge.c ts_query_cursor_exec_p" + ts_query_cursor_exec_p :: + Ptr TSQueryCursor -> Ptr TSQuery -> Ptr Node -> IO () + +foreign import ccall safe "ts_query_cursor_next_match" + ts_query_cursor_next_match :: + Ptr TSQueryCursor -> Ptr TSQueryMatch -> IO Bool diff --git a/tree-sitter/src/TreeSitter/Struct.hs b/tree-sitter/src/TreeSitter/Struct.hs new file mode 100644 index 00000000..9bde07c7 --- /dev/null +++ b/tree-sitter/src/TreeSitter/Struct.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables,TypeOperators , DeriveAnyClass#-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module TreeSitter.Struct (Struct, evalStruct, peekStruct, pokeStruct) where + +import Foreign + +-- | 'Struct' is a strict 'Monad' with automatic alignment & advancing, & inferred type. +newtype Struct a = Struct { runStruct :: forall b . Ptr b -> IO (a, Ptr a) } + +instance Functor Struct where + fmap f a = Struct go where + go p = do + (a', p') <- runStruct a p + let fa = f a' + fa `seq` p' `seq` pure (fa, castPtr p') + {-# INLINE go #-} + {-# INLINE fmap #-} + +instance Applicative Struct where + pure a = Struct (\ p -> pure (a, castPtr p)) + {-# INLINE pure #-} + + f <*> a = Struct go where + go p = do + (f', p') <- runStruct f p + (a', p'') <- p' `seq` runStruct a (castPtr p') + let fa = f' a' + fa `seq` p'' `seq` pure (fa, castPtr p'') + {-# INLINE go #-} + {-# INLINE (<*>) #-} + +instance Monad Struct where + return = pure + {-# INLINE return #-} + + a >>= f = Struct go where + go p = do + (a', p') <- runStruct a p + (fa', p'') <- p' `seq` runStruct (f a') (castPtr p') + fa' `seq` p'' `seq` pure (fa', p'') + {-# INLINE go #-} + {-# INLINE (>>=) #-} + +evalStruct :: Struct a -> Ptr b -> IO a +evalStruct s p = fmap fst $! runStruct s p +{-# INLINE evalStruct #-} + +peekStruct :: forall a . Storable a => Struct a +peekStruct = Struct + ( \p -> do + let aligned = alignPtr (castPtr p) (alignment (undefined :: a)) + a <- peek aligned + pure (a, aligned `plusPtr` sizeOf a) + ) +{-# INLINE peekStruct #-} + +pokeStruct :: Storable a => a -> Struct () +pokeStruct a = Struct + ( \p -> do + let aligned = alignPtr (castPtr p) (alignment a) + poke aligned a + pure ((), castPtr aligned `plusPtr` sizeOf a) + ) diff --git a/tree-sitter/src/bridge.c b/tree-sitter/src/bridge.c index cee05c01..e0f455be 100644 --- a/tree-sitter/src/bridge.c +++ b/tree-sitter/src/bridge.c @@ -1,29 +1,31 @@ -#include "tree_sitter/api.h" #include #include #include +#include "tree_sitter/api.h" + typedef struct Node { TSNode node; - const char *type; + const char* type; TSSymbol symbol; TSPoint endPoint; uint32_t endByte; uint32_t childCount; - const char *fieldName; - bool isNamed; - bool isExtra; + const char* fieldName; + bool isNamed; + bool isExtra; } Node; -void log_to_stdout(void *payload, TSLogType type, const char *message) { +void log_to_stdout(void* payload, TSLogType type, const char* message) { printf("%s\n", message); } -void ts_parser_log_to_stderr(TSParser *parser) { - ts_parser_set_logger(parser, (TSLogger) {.log = log_to_stdout, .payload = NULL}); +void ts_parser_log_to_stderr(TSParser* parser) { + ts_parser_set_logger(parser, + (TSLogger){.log = log_to_stdout, .payload = NULL}); } -static inline void ts_node_poke(const char *fieldName, TSNode node, Node *out) { +static inline void ts_node_poke(const char* fieldName, TSNode node, Node* out) { out->node = node; out->symbol = ts_node_symbol(node); out->type = ts_node_type(node); @@ -35,12 +37,27 @@ static inline void ts_node_poke(const char *fieldName, TSNode node, Node *out) { out->isExtra = ts_node_is_extra(node); } -void ts_node_poke_p(TSNode *node, Node *out) { +char* ts_node_string_p(TSNode* node) { + assert(node != NULL); + return ts_node_string(*node); +} + +void ts_query_cursor_exec_p(TSQueryCursor* cursor, + const TSQuery* query, + Node* node) { + assert(cursor != NULL); + assert(query != NULL); + assert(node != NULL); + ts_query_cursor_exec(cursor, query, node->node); +} + +void ts_node_poke_p(TSNode* node, Node* out) { assert(node != NULL); + assert(out != NULL); ts_node_poke(NULL, *node, out); } -void ts_tree_root_node_p(TSTree *tree, Node *outNode) { +void ts_tree_root_node_p(TSTree* tree, Node* outNode) { assert(tree != NULL); assert(outNode != NULL); TSNode root = ts_tree_root_node(tree); @@ -48,7 +65,7 @@ void ts_tree_root_node_p(TSTree *tree, Node *outNode) { ts_node_poke(NULL, root, outNode); } -void ts_node_copy_child_nodes(const TSNode *parentNode, Node *outChildNodes) { +void ts_node_copy_child_nodes(const TSNode* parentNode, Node* outChildNodes) { assert(parentNode != NULL); assert(outChildNodes != NULL); TSTreeCursor curse = ts_tree_cursor_new(*parentNode); @@ -56,7 +73,8 @@ void ts_node_copy_child_nodes(const TSNode *parentNode, Node *outChildNodes) { if (ts_tree_cursor_goto_first_child(&curse)) { do { TSNode current = ts_tree_cursor_current_node(&curse); - ts_node_poke(ts_tree_cursor_current_field_name(&curse), current, outChildNodes); + ts_node_poke(ts_tree_cursor_current_field_name(&curse), current, + outChildNodes); outChildNodes++; } while (ts_tree_cursor_goto_next_sibling(&curse)); } @@ -80,20 +98,19 @@ size_t sizeof_tstreecursor() { return sizeof(TSTreeCursor); } - -void ts_tree_cursor_new_p(TSNode *node, TSTreeCursor *outCursor) { +void ts_tree_cursor_new_p(TSNode* node, TSTreeCursor* outCursor) { assert(node != NULL); assert(outCursor != NULL); *outCursor = ts_tree_cursor_new(*node); } -void ts_tree_cursor_reset_p(TSTreeCursor *cursor, TSNode *node) { +void ts_tree_cursor_reset_p(TSTreeCursor* cursor, TSNode* node) { assert(cursor != NULL); assert(node != NULL); ts_tree_cursor_reset(cursor, *node); } -bool ts_tree_cursor_current_node_p(const TSTreeCursor *cursor, Node *outNode) { +bool ts_tree_cursor_current_node_p(const TSTreeCursor* cursor, Node* outNode) { assert(cursor != NULL); assert(outNode != NULL); TSNode tsNode = ts_tree_cursor_current_node(cursor); @@ -103,8 +120,8 @@ bool ts_tree_cursor_current_node_p(const TSTreeCursor *cursor, Node *outNode) { return false; } - -uint32_t ts_tree_cursor_copy_child_nodes(TSTreeCursor *cursor, Node *outChildNodes) { +uint32_t ts_tree_cursor_copy_child_nodes(TSTreeCursor* cursor, + Node* outChildNodes) { assert(cursor != NULL); assert(outChildNodes != NULL); uint32_t count = 0; @@ -112,8 +129,9 @@ uint32_t ts_tree_cursor_copy_child_nodes(TSTreeCursor *cursor, Node *outChildNod if (ts_tree_cursor_goto_first_child(cursor)) { do { TSNode current = ts_tree_cursor_current_node(cursor); - const char *fieldName = ts_tree_cursor_current_field_name(cursor); - if (fieldName || (ts_node_is_named(current) && !ts_node_is_extra(current))) { + const char* fieldName = ts_tree_cursor_current_field_name(cursor); + if (fieldName || + (ts_node_is_named(current) && !ts_node_is_extra(current))) { ts_node_poke(fieldName, current, outChildNodes); count++; outChildNodes++; diff --git a/tree-sitter/test/TreeSitter/Example.hs b/tree-sitter/test/TreeSitter/Example.hs index 2ad9d6d7..4b2dedbb 100644 --- a/tree-sitter/test/TreeSitter/Example.hs +++ b/tree-sitter/test/TreeSitter/Example.hs @@ -1,43 +1,68 @@ {-# LANGUAGE TemplateHaskell #-} -module TreeSitter.Example (tests) where +module TreeSitter.Example + ( tests + ) +where -import Control.Monad.IO.Class -import Foreign -import Foreign.C.Types -import Hedgehog -import TreeSitter.Cursor -import TreeSitter.Node -import TreeSitter.Parser +import Control.Monad.IO.Class +import Foreign +import Foreign.C.Types +import Hedgehog +import TreeSitter.Cursor +import TreeSitter.Node +import TreeSitter.Parser +import TreeSitter.Language tests :: IO Bool tests = checkSequential $$(discover) -prop_TSNode_sizeOf = property $ - sizeOf (undefined :: TSNode) === fromIntegral sizeof_tsnode +prop_TSNode_sizeOf = + property $ sizeOf (undefined :: TSNode) === fromIntegral sizeof_tsnode prop_TSNode_roundtrips = property $ do peeked <- liftIO (with (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) peek) - peeked === TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr + peeked === TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr -prop_TSPoint_sizeOf = property $ - sizeOf (undefined :: TSPoint) === fromIntegral sizeof_tspoint +prop_TSPoint_sizeOf = + property $ sizeOf (undefined :: TSPoint) === fromIntegral sizeof_tspoint prop_TSPoint_roundtrips = property $ do peeked <- liftIO (with (TSPoint 1 2) peek) - peeked === TSPoint 1 2 + peeked === TSPoint 1 2 -prop_Node_sizeOf = property $ - sizeOf (undefined :: Node) === fromIntegral sizeof_node +prop_Node_sizeOf = + property $ sizeOf (undefined :: Node) === fromIntegral sizeof_node prop_Node_roundtrips = property $ do - peeked <- liftIO (with (Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) nullPtr 1 (TSPoint 4 5) 7 8 nullPtr 9 10) peek) - peeked === Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) nullPtr 1 (TSPoint 4 5) 7 8 nullPtr 9 10 + peeked <- liftIO + (with + (Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) + nullPtr + 1 + (TSPoint 4 5) + 7 + 8 + nullPtr + 9 + 10 + ) + peek + ) + peeked === Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) + nullPtr + 1 + (TSPoint 4 5) + 7 + 8 + nullPtr + 9 + 10 -prop_TSTreeCursor_sizeOf = property $ - sizeOfCursor === fromIntegral sizeof_tstreecursor +prop_TSTreeCursor_sizeOf = + property $ sizeOfCursor === fromIntegral sizeof_tstreecursor prop_Parser_timeout = property $ do - parser <- liftIO ts_parser_new + parser <- liftIO ts_parser_new timeout <- liftIO (ts_parser_timeout_micros parser) timeout === 0 liftIO (ts_parser_set_timeout_micros parser 1000) @@ -49,3 +74,4 @@ foreign import ccall unsafe "src/bridge.c sizeof_tsnode" sizeof_tsnode :: CSize foreign import ccall unsafe "src/bridge.c sizeof_tspoint" sizeof_tspoint :: CSize foreign import ccall unsafe "src/bridge.c sizeof_node" sizeof_node :: CSize foreign import ccall unsafe "src/bridge.c sizeof_tstreecursor" sizeof_tstreecursor :: CSize +foreign import ccall unsafe "src/bridge.c ts_query_new_p" ts_query_new_p :: CSize diff --git a/tree-sitter/tree-sitter.cabal b/tree-sitter/tree-sitter.cabal index a93d51cc..b549e417 100644 --- a/tree-sitter/tree-sitter.cabal +++ b/tree-sitter/tree-sitter.cabal @@ -65,6 +65,8 @@ library , TreeSitter.Symbol , TreeSitter.Tree , TreeSitter.Cursor + , TreeSitter.Query + other-modules: TreeSitter.Struct include-dirs: vendor/tree-sitter/lib/include , vendor/tree-sitter/lib/src install-includes: tree_sitter/api.h From 42d69a23beca3612e900a6ffe35566204fd07a82 Mon Sep 17 00:00:00 2001 From: Gaute Berge Date: Fri, 11 Sep 2020 13:57:24 +0200 Subject: [PATCH 2/7] Revert files that shouldent have been changed --- tree-sitter-haskell/examples/Demo.hs | 90 +++++++++++--------------- tree-sitter/test/TreeSitter/Example.hs | 68 ++++++------------- 2 files changed, 58 insertions(+), 100 deletions(-) diff --git a/tree-sitter-haskell/examples/Demo.hs b/tree-sitter-haskell/examples/Demo.hs index 0c7c9023..a6d6f199 100644 --- a/tree-sitter-haskell/examples/Demo.hs +++ b/tree-sitter-haskell/examples/Demo.hs @@ -1,96 +1,80 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Main (main) where +module Main where -import qualified Data.Tree as Tree import TreeSitter.Parser import TreeSitter.Tree -import TreeSitter.Query --- import TreeSitter.Language +import TreeSitter.Language import TreeSitter.Haskell import TreeSitter.Node import Foreign.C.String -import Foreign.Ptr ( Ptr +import Foreign.C.Types +import Foreign.Ptr ( Ptr(..) , nullPtr + , plusPtr + ) +import Foreign.Marshal.Alloc ( malloc + , mallocBytes ) -import Foreign.Marshal.Alloc ( malloc) import Foreign.Marshal.Array ( mallocArray ) import Foreign.Storable ( peek , peekElemOff , poke ) +import Foreign.Marshal.Utils ( new ) import Control.Monad + main :: IO () main = do parser <- ts_parser_new - _ <- ts_parser_set_language parser tree_sitter_haskell - let source = "module Test (main) where\nimport Lib\nf1 = undefined" - -- "module Test (main) where\nimport Lib\nf1 = undefined\nf2 = undefined" - - (str, len) <- newCStringLen source - tree <- ts_parser_parse_string parser nullPtr str len - nodePointer <- malloc - ts_tree_root_node_p tree nodePointer - node <- peek nodePointer - print =<< nodeString node - -- ast <- toAst node - -- print ast + ts_parser_set_language parser tree_sitter_haskell - let source = "(function_body) @f" - (str, len) <- newCStringLen source - errorOffset <- malloc - errorType <- malloc - cursor <- ts_query_cursor_new - query <- ts_query_new tree_sitter_haskell str len errorOffset errorType - ts_query_cursor_exec_p cursor query nodePointer - matchPointer <- malloc + let source = + "module Test (main) where\nimport Lib\nf1 = undefined\nf2 = undefined" - success <- ts_query_cursor_next_match cursor matchPointer - print $ "success: " ++ show success - match <- (peek matchPointer) - capture <- peek $ captures match - print capture + (str, len) <- newCStringLen source + tree <- ts_parser_parse_string parser nullPtr str len - ts_node <- malloc - poke ts_node (captureTSNode capture) - ts_node_string_p ts_node >>= peekCString >>= print + n <- malloc + ts_tree_root_node_p tree n - success <- ts_query_cursor_next_match cursor matchPointer - print $ "success: " ++ show success - -type Ast = Tree.Tree Node' -data Node' = Node' {type_::String, text :: String} deriving Show - -toAst :: Node -> IO Ast -toAst Node {..} = do - -- Node {..} <- peek n - theType <- peekCString nodeType + print "module (root) ------------" + n@Node {..} <- peek n let childCount = fromIntegral nodeChildCount + children <- mallocArray childCount tsNode <- malloc - poke tsNode nodeTSNode + poke tsNode nodeTSNode ts_node_copy_child_nodes tsNode children - text <- ts_node_string_p tsNode >>= peekCString - children' <- forM [0 .. childCount - 1] $ \n -> do - child <- peekElemOff children n - toAst child - return $ Tree.Node (Node' theType text) children' + printChildren children childCount + + print "where ------------" + n@Node {..} <- peekElemOff children 3 + let nextChildCount = fromIntegral nodeChildCount + + nextChildren <- mallocArray nextChildCount + nextTsNode <- malloc + poke nextTsNode nodeTSNode + ts_node_copy_child_nodes nextTsNode nextChildren + + printChildren nextChildren nextChildCount + print "END" printChildren :: Ptr Node -> Int -> IO () printChildren children count = forM_ [0 .. count - 1] - ( \n -> do + (\n -> do child <- peekElemOff children n printNode child ) printNode :: Node -> IO () -printNode n@Node {..} = do +printNode Node {..} = do theType <- peekCString nodeType - let TSPoint {..} = nodeStartPoint n + let TSPoint {..} = nodeStartPoint start = "(" ++ show pointRow ++ "," ++ show pointColumn ++ ")" let TSPoint {..} = nodeEndPoint end = "(" ++ show pointRow ++ "," ++ show pointColumn ++ ")" diff --git a/tree-sitter/test/TreeSitter/Example.hs b/tree-sitter/test/TreeSitter/Example.hs index 4b2dedbb..2ad9d6d7 100644 --- a/tree-sitter/test/TreeSitter/Example.hs +++ b/tree-sitter/test/TreeSitter/Example.hs @@ -1,68 +1,43 @@ {-# LANGUAGE TemplateHaskell #-} -module TreeSitter.Example - ( tests - ) -where +module TreeSitter.Example (tests) where -import Control.Monad.IO.Class -import Foreign -import Foreign.C.Types -import Hedgehog -import TreeSitter.Cursor -import TreeSitter.Node -import TreeSitter.Parser -import TreeSitter.Language +import Control.Monad.IO.Class +import Foreign +import Foreign.C.Types +import Hedgehog +import TreeSitter.Cursor +import TreeSitter.Node +import TreeSitter.Parser tests :: IO Bool tests = checkSequential $$(discover) -prop_TSNode_sizeOf = - property $ sizeOf (undefined :: TSNode) === fromIntegral sizeof_tsnode +prop_TSNode_sizeOf = property $ + sizeOf (undefined :: TSNode) === fromIntegral sizeof_tsnode prop_TSNode_roundtrips = property $ do peeked <- liftIO (with (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) peek) - peeked === TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr + peeked === TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr -prop_TSPoint_sizeOf = - property $ sizeOf (undefined :: TSPoint) === fromIntegral sizeof_tspoint +prop_TSPoint_sizeOf = property $ + sizeOf (undefined :: TSPoint) === fromIntegral sizeof_tspoint prop_TSPoint_roundtrips = property $ do peeked <- liftIO (with (TSPoint 1 2) peek) - peeked === TSPoint 1 2 + peeked === TSPoint 1 2 -prop_Node_sizeOf = - property $ sizeOf (undefined :: Node) === fromIntegral sizeof_node +prop_Node_sizeOf = property $ + sizeOf (undefined :: Node) === fromIntegral sizeof_node prop_Node_roundtrips = property $ do - peeked <- liftIO - (with - (Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) - nullPtr - 1 - (TSPoint 4 5) - 7 - 8 - nullPtr - 9 - 10 - ) - peek - ) - peeked === Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) - nullPtr - 1 - (TSPoint 4 5) - 7 - 8 - nullPtr - 9 - 10 + peeked <- liftIO (with (Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) nullPtr 1 (TSPoint 4 5) 7 8 nullPtr 9 10) peek) + peeked === Node (TSNode 1 (TSPoint 2 3) 4 nullPtr nullPtr) nullPtr 1 (TSPoint 4 5) 7 8 nullPtr 9 10 -prop_TSTreeCursor_sizeOf = - property $ sizeOfCursor === fromIntegral sizeof_tstreecursor +prop_TSTreeCursor_sizeOf = property $ + sizeOfCursor === fromIntegral sizeof_tstreecursor prop_Parser_timeout = property $ do - parser <- liftIO ts_parser_new + parser <- liftIO ts_parser_new timeout <- liftIO (ts_parser_timeout_micros parser) timeout === 0 liftIO (ts_parser_set_timeout_micros parser 1000) @@ -74,4 +49,3 @@ foreign import ccall unsafe "src/bridge.c sizeof_tsnode" sizeof_tsnode :: CSize foreign import ccall unsafe "src/bridge.c sizeof_tspoint" sizeof_tspoint :: CSize foreign import ccall unsafe "src/bridge.c sizeof_node" sizeof_node :: CSize foreign import ccall unsafe "src/bridge.c sizeof_tstreecursor" sizeof_tstreecursor :: CSize -foreign import ccall unsafe "src/bridge.c ts_query_new_p" ts_query_new_p :: CSize From 4f4c878d19458e5cba9e57f2036f73b16860d99f Mon Sep 17 00:00:00 2001 From: Gaute Berge Date: Fri, 11 Sep 2020 14:23:32 +0200 Subject: [PATCH 3/7] Cleanup --- tree-sitter-haskell/examples/QueryDemo.hs | 2 +- tree-sitter-haskell/tree-sitter-haskell.cabal | 4 +- tree-sitter/src/TreeSitter/Query.hs | 44 ++++++++++--------- 3 files changed, 26 insertions(+), 24 deletions(-) diff --git a/tree-sitter-haskell/examples/QueryDemo.hs b/tree-sitter-haskell/examples/QueryDemo.hs index 628c3217..3aee30be 100644 --- a/tree-sitter-haskell/examples/QueryDemo.hs +++ b/tree-sitter-haskell/examples/QueryDemo.hs @@ -37,7 +37,7 @@ main = do success <- ts_query_cursor_next_match cursor matchPointer print $ "success: " ++ show success match <- (peek matchPointer) - capture <- peek $ captures match + capture <- peek $ matchCaptures match print capture -- print the match diff --git a/tree-sitter-haskell/tree-sitter-haskell.cabal b/tree-sitter-haskell/tree-sitter-haskell.cabal index cf0d6699..bf51dec8 100644 --- a/tree-sitter-haskell/tree-sitter-haskell.cabal +++ b/tree-sitter-haskell/tree-sitter-haskell.cabal @@ -36,7 +36,7 @@ common common flag build-examples description: Build tree-sitter-haskell examples. - default: True + default: False executable query-demo import: common @@ -47,7 +47,6 @@ executable query-demo ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base - , containers , tree-sitter , tree-sitter-haskell @@ -60,7 +59,6 @@ executable demo ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base - , containers , tree-sitter , tree-sitter-haskell diff --git a/tree-sitter/src/TreeSitter/Query.hs b/tree-sitter/src/TreeSitter/Query.hs index daad9fdd..1e87e145 100644 --- a/tree-sitter/src/TreeSitter/Query.hs +++ b/tree-sitter/src/TreeSitter/Query.hs @@ -5,9 +5,12 @@ module TreeSitter.Query ( TSQuery , TSQueryCursor - , pattern_index - , captures , captureTSNode + , captureIndex + , matchId + , matchPatternindex + , matchCaptureCount + , matchCaptures , ts_query_new , ts_query_cursor_exec_p , ts_query_cursor_new @@ -25,53 +28,54 @@ data TSQuery data TSQueryCursor -type TSQueryError = Int -- TODO: Need help implementing storable -- data TSQueryError = TSQueryErrorNone | TSQueryErrorSyntax | TSQueryErrorNodeType | TSQueryErrorField | TSQueryErrorCapture -- deriving (Show, Enum) +type TSQueryError = Int data TSQueryCapture = TSQueryCapture { captureTSNode :: !TSNode - , index :: !Word32 + , captureIndex :: !Word32 } deriving (Show, Eq, Generic) data TSQueryMatch = TSQueryMatch - { id :: !Word32 - , pattern_index :: !Word16 - , capture_count :: !Word16 - , captures :: Ptr TSQueryCapture + { matchId :: !Word32 + , matchPatternindex :: !Word16 + , matchCaptureCount :: !Word16 + , matchCaptures :: Ptr TSQueryCapture } deriving (Show, Eq, Generic) -instance Storable TSQueryMatch where +instance Storable TSQueryCapture where alignment _ = alignment (0 :: Int32) {-# INLINE alignment #-} - sizeOf _ = 80 + sizeOf _ = 8 {-# INLINE sizeOf #-} - peek = - evalStruct $ - TSQueryMatch <$> peekStruct <*> peekStruct <*> peekStruct <*> peekStruct + peek = evalStruct $ TSQueryCapture <$> peekStruct <*> peekStruct {-# INLINE peek #-} - poke ptr (TSQueryMatch a b c d) = + poke ptr (TSQueryCapture a b) = flip evalStruct ptr $ do pokeStruct a pokeStruct b - pokeStruct c - pokeStruct d {-# INLINE poke #-} -instance Storable TSQueryCapture where +instance Storable TSQueryMatch where alignment _ = alignment (0 :: Int32) {-# INLINE alignment #-} - sizeOf _ = 8 + sizeOf _ = 80 {-# INLINE sizeOf #-} - peek = evalStruct $ TSQueryCapture <$> peekStruct <*> peekStruct + peek = + evalStruct $ + TSQueryMatch <$> peekStruct <*> peekStruct <*> peekStruct <*> peekStruct {-# INLINE peek #-} - poke ptr (TSQueryCapture a b) = + poke ptr (TSQueryMatch a b c d) = flip evalStruct ptr $ do pokeStruct a pokeStruct b + pokeStruct c + pokeStruct d {-# INLINE poke #-} + foreign import ccall safe "ts_query_new" ts_query_new :: Ptr Language -> CString -> From 1688ca206ad966aab0ceb424e13804f9339260f7 Mon Sep 17 00:00:00 2001 From: Gaute Berge Date: Fri, 11 Sep 2020 14:31:08 +0200 Subject: [PATCH 4/7] Fix sizeOf in query structures. Add doc string to uninhabited data --- tree-sitter/src/TreeSitter/Query.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/tree-sitter/src/TreeSitter/Query.hs b/tree-sitter/src/TreeSitter/Query.hs index 1e87e145..9a536898 100644 --- a/tree-sitter/src/TreeSitter/Query.hs +++ b/tree-sitter/src/TreeSitter/Query.hs @@ -24,8 +24,14 @@ import TreeSitter.Language import TreeSitter.Node import TreeSitter.Struct +-- | A tree-sitter query. +-- +-- This type is uninhabited and used only for type safety within 'Ptr' values. data TSQuery +-- | A tree-sitter query cursor. +-- +-- This type is uninhabited and used only for type safety within 'Ptr' values. data TSQueryCursor -- TODO: Need help implementing storable @@ -48,7 +54,7 @@ data TSQueryMatch = TSQueryMatch instance Storable TSQueryCapture where alignment _ = alignment (0 :: Int32) {-# INLINE alignment #-} - sizeOf _ = 8 + sizeOf _ = 10 {-# INLINE sizeOf #-} peek = evalStruct $ TSQueryCapture <$> peekStruct <*> peekStruct {-# INLINE peek #-} @@ -61,7 +67,7 @@ instance Storable TSQueryCapture where instance Storable TSQueryMatch where alignment _ = alignment (0 :: Int32) {-# INLINE alignment #-} - sizeOf _ = 80 + sizeOf _ = 12 {-# INLINE sizeOf #-} peek = evalStruct $ From 729da7bc822c09fa83046eed13bc1abd351a84df Mon Sep 17 00:00:00 2001 From: Gaute Berge Date: Fri, 11 Sep 2020 15:03:37 +0200 Subject: [PATCH 5/7] revert clang format --- tree-sitter/src/bridge.c | 72 ++++++++++++++++++---------------------- 1 file changed, 33 insertions(+), 39 deletions(-) diff --git a/tree-sitter/src/bridge.c b/tree-sitter/src/bridge.c index e0f455be..4a8deaad 100644 --- a/tree-sitter/src/bridge.c +++ b/tree-sitter/src/bridge.c @@ -1,40 +1,26 @@ +#include "tree_sitter/api.h" #include #include #include -#include "tree_sitter/api.h" - typedef struct Node { TSNode node; - const char* type; + const char *type; TSSymbol symbol; TSPoint endPoint; uint32_t endByte; uint32_t childCount; - const char* fieldName; - bool isNamed; - bool isExtra; + const char *fieldName; + bool isNamed; + bool isExtra; } Node; -void log_to_stdout(void* payload, TSLogType type, const char* message) { +void log_to_stdout(void *payload, TSLogType type, const char *message) { printf("%s\n", message); } -void ts_parser_log_to_stderr(TSParser* parser) { - ts_parser_set_logger(parser, - (TSLogger){.log = log_to_stdout, .payload = NULL}); -} - -static inline void ts_node_poke(const char* fieldName, TSNode node, Node* out) { - out->node = node; - out->symbol = ts_node_symbol(node); - out->type = ts_node_type(node); - out->endPoint = ts_node_end_point(node); - out->endByte = ts_node_end_byte(node); - out->childCount = ts_node_child_count(node); - out->fieldName = fieldName; - out->isNamed = ts_node_is_named(node); - out->isExtra = ts_node_is_extra(node); +void ts_parser_log_to_stderr(TSParser *parser) { + ts_parser_set_logger(parser, (TSLogger) {.log = log_to_stdout, .payload = NULL}); } char* ts_node_string_p(TSNode* node) { @@ -42,22 +28,31 @@ char* ts_node_string_p(TSNode* node) { return ts_node_string(*node); } -void ts_query_cursor_exec_p(TSQueryCursor* cursor, - const TSQuery* query, - Node* node) { +void ts_query_cursor_exec_p(TSQueryCursor* cursor, const TSQuery* query, Node* node) { assert(cursor != NULL); assert(query != NULL); assert(node != NULL); ts_query_cursor_exec(cursor, query, node->node); } -void ts_node_poke_p(TSNode* node, Node* out) { +static inline void ts_node_poke(const char *fieldName, TSNode node, Node *out) { + out->node = node; + out->symbol = ts_node_symbol(node); + out->type = ts_node_type(node); + out->endPoint = ts_node_end_point(node); + out->endByte = ts_node_end_byte(node); + out->childCount = ts_node_child_count(node); + out->fieldName = fieldName; + out->isNamed = ts_node_is_named(node); + out->isExtra = ts_node_is_extra(node); +} + +void ts_node_poke_p(TSNode *node, Node *out) { assert(node != NULL); - assert(out != NULL); ts_node_poke(NULL, *node, out); } -void ts_tree_root_node_p(TSTree* tree, Node* outNode) { +void ts_tree_root_node_p(TSTree *tree, Node *outNode) { assert(tree != NULL); assert(outNode != NULL); TSNode root = ts_tree_root_node(tree); @@ -65,7 +60,7 @@ void ts_tree_root_node_p(TSTree* tree, Node* outNode) { ts_node_poke(NULL, root, outNode); } -void ts_node_copy_child_nodes(const TSNode* parentNode, Node* outChildNodes) { +void ts_node_copy_child_nodes(const TSNode *parentNode, Node *outChildNodes) { assert(parentNode != NULL); assert(outChildNodes != NULL); TSTreeCursor curse = ts_tree_cursor_new(*parentNode); @@ -73,8 +68,7 @@ void ts_node_copy_child_nodes(const TSNode* parentNode, Node* outChildNodes) { if (ts_tree_cursor_goto_first_child(&curse)) { do { TSNode current = ts_tree_cursor_current_node(&curse); - ts_node_poke(ts_tree_cursor_current_field_name(&curse), current, - outChildNodes); + ts_node_poke(ts_tree_cursor_current_field_name(&curse), current, outChildNodes); outChildNodes++; } while (ts_tree_cursor_goto_next_sibling(&curse)); } @@ -98,19 +92,20 @@ size_t sizeof_tstreecursor() { return sizeof(TSTreeCursor); } -void ts_tree_cursor_new_p(TSNode* node, TSTreeCursor* outCursor) { + +void ts_tree_cursor_new_p(TSNode *node, TSTreeCursor *outCursor) { assert(node != NULL); assert(outCursor != NULL); *outCursor = ts_tree_cursor_new(*node); } -void ts_tree_cursor_reset_p(TSTreeCursor* cursor, TSNode* node) { +void ts_tree_cursor_reset_p(TSTreeCursor *cursor, TSNode *node) { assert(cursor != NULL); assert(node != NULL); ts_tree_cursor_reset(cursor, *node); } -bool ts_tree_cursor_current_node_p(const TSTreeCursor* cursor, Node* outNode) { +bool ts_tree_cursor_current_node_p(const TSTreeCursor *cursor, Node *outNode) { assert(cursor != NULL); assert(outNode != NULL); TSNode tsNode = ts_tree_cursor_current_node(cursor); @@ -120,8 +115,8 @@ bool ts_tree_cursor_current_node_p(const TSTreeCursor* cursor, Node* outNode) { return false; } -uint32_t ts_tree_cursor_copy_child_nodes(TSTreeCursor* cursor, - Node* outChildNodes) { + +uint32_t ts_tree_cursor_copy_child_nodes(TSTreeCursor *cursor, Node *outChildNodes) { assert(cursor != NULL); assert(outChildNodes != NULL); uint32_t count = 0; @@ -129,9 +124,8 @@ uint32_t ts_tree_cursor_copy_child_nodes(TSTreeCursor* cursor, if (ts_tree_cursor_goto_first_child(cursor)) { do { TSNode current = ts_tree_cursor_current_node(cursor); - const char* fieldName = ts_tree_cursor_current_field_name(cursor); - if (fieldName || - (ts_node_is_named(current) && !ts_node_is_extra(current))) { + const char *fieldName = ts_tree_cursor_current_field_name(cursor); + if (fieldName || (ts_node_is_named(current) && !ts_node_is_extra(current))) { ts_node_poke(fieldName, current, outChildNodes); count++; outChildNodes++; From 20352db51c474ba293129a1e0bc361aa75573a7d Mon Sep 17 00:00:00 2001 From: Gaute Berge Date: Fri, 11 Sep 2020 15:18:40 +0200 Subject: [PATCH 6/7] Removed unused pragmas. Formatting --- tree-sitter/src/TreeSitter/Query.hs | 63 +++++++++++++---------------- 1 file changed, 27 insertions(+), 36 deletions(-) diff --git a/tree-sitter/src/TreeSitter/Query.hs b/tree-sitter/src/TreeSitter/Query.hs index 9a536898..b4d2b74e 100644 --- a/tree-sitter/src/TreeSitter/Query.hs +++ b/tree-sitter/src/TreeSitter/Query.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, RankNTypes, - ScopedTypeVariables, TypeOperators, DeriveAnyClass #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE DeriveGeneric #-} module TreeSitter.Query ( TSQuery @@ -15,14 +13,15 @@ module TreeSitter.Query , ts_query_cursor_exec_p , ts_query_cursor_new , ts_query_cursor_next_match - ) where + ) +where -import Foreign -import Foreign.C (CString) -import GHC.Generics -import TreeSitter.Language -import TreeSitter.Node -import TreeSitter.Struct +import Foreign +import Foreign.C ( CString ) +import GHC.Generics +import TreeSitter.Language +import TreeSitter.Node +import TreeSitter.Struct -- | A tree-sitter query. -- @@ -58,10 +57,9 @@ instance Storable TSQueryCapture where {-# INLINE sizeOf #-} peek = evalStruct $ TSQueryCapture <$> peekStruct <*> peekStruct {-# INLINE peek #-} - poke ptr (TSQueryCapture a b) = - flip evalStruct ptr $ do - pokeStruct a - pokeStruct b + poke ptr (TSQueryCapture a b) = flip evalStruct ptr $ do + pokeStruct a + pokeStruct b {-# INLINE poke #-} instance Storable TSQueryMatch where @@ -70,30 +68,23 @@ instance Storable TSQueryMatch where sizeOf _ = 12 {-# INLINE sizeOf #-} peek = - evalStruct $ - TSQueryMatch <$> peekStruct <*> peekStruct <*> peekStruct <*> peekStruct + evalStruct + $ TSQueryMatch + <$> peekStruct + <*> peekStruct + <*> peekStruct + <*> peekStruct {-# INLINE peek #-} - poke ptr (TSQueryMatch a b c d) = - flip evalStruct ptr $ do - pokeStruct a - pokeStruct b - pokeStruct c - pokeStruct d + poke ptr (TSQueryMatch a b c d) = flip evalStruct ptr $ do + pokeStruct a + pokeStruct b + pokeStruct c + pokeStruct d {-# INLINE poke #-} -foreign import ccall safe "ts_query_new" ts_query_new :: - Ptr Language -> - CString -> - Int -> Ptr Word32 -> Ptr TSQueryError -> IO (Ptr TSQuery) +foreign import ccall safe "ts_query_new" ts_query_new :: Ptr Language -> CString -> Int -> Ptr Word32 -> Ptr TSQueryError -> IO (Ptr TSQuery) +foreign import ccall safe "ts_query_cursor_new" ts_query_cursor_new :: IO (Ptr TSQueryCursor) +foreign import ccall safe "src/bridge.c ts_query_cursor_exec_p" ts_query_cursor_exec_p :: Ptr TSQueryCursor -> Ptr TSQuery -> Ptr Node -> IO () +foreign import ccall safe "ts_query_cursor_next_match" ts_query_cursor_next_match :: Ptr TSQueryCursor -> Ptr TSQueryMatch -> IO Bool -foreign import ccall safe "ts_query_cursor_new" ts_query_cursor_new - :: IO (Ptr TSQueryCursor) - -foreign import ccall safe "src/bridge.c ts_query_cursor_exec_p" - ts_query_cursor_exec_p :: - Ptr TSQueryCursor -> Ptr TSQuery -> Ptr Node -> IO () - -foreign import ccall safe "ts_query_cursor_next_match" - ts_query_cursor_next_match :: - Ptr TSQueryCursor -> Ptr TSQueryMatch -> IO Bool From d2c99aea7524908c36adbbd45402bdadae4cdd09 Mon Sep 17 00:00:00 2001 From: Gaute Berge Date: Sat, 12 Sep 2020 09:58:53 +0200 Subject: [PATCH 7/7] TSQueryError with storable instance --- tree-sitter/src/TreeSitter/Query.hs | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/tree-sitter/src/TreeSitter/Query.hs b/tree-sitter/src/TreeSitter/Query.hs index b4d2b74e..721ce8fc 100644 --- a/tree-sitter/src/TreeSitter/Query.hs +++ b/tree-sitter/src/TreeSitter/Query.hs @@ -3,6 +3,7 @@ module TreeSitter.Query ( TSQuery , TSQueryCursor + , TSQueryError(..) , captureTSNode , captureIndex , matchId @@ -33,10 +34,13 @@ data TSQuery -- This type is uninhabited and used only for type safety within 'Ptr' values. data TSQueryCursor --- TODO: Need help implementing storable --- data TSQueryError = TSQueryErrorNone | TSQueryErrorSyntax | TSQueryErrorNodeType | TSQueryErrorField | TSQueryErrorCapture --- deriving (Show, Enum) -type TSQueryError = Int +data TSQueryError + = TSQueryErrorNone + | TSQueryErrorSyntax + | TSQueryErrorNodeType + | TSQueryErrorField + | TSQueryErrorCapture + deriving (Show, Enum, Eq) data TSQueryCapture = TSQueryCapture { captureTSNode :: !TSNode @@ -50,6 +54,16 @@ data TSQueryMatch = TSQueryMatch , matchCaptures :: Ptr TSQueryCapture } deriving (Show, Eq, Generic) +instance Storable TSQueryError where + alignment _ = alignment (0 :: Int8) + {-# INLINE alignment #-} + sizeOf _ = 1 + {-# INLINE sizeOf #-} + peek = evalStruct $ toEnum <$> peekStruct + {-# INLINE peek #-} + poke ptr e = evalStruct (pokeStruct $ fromEnum e) ptr + {-# INLINE poke #-} + instance Storable TSQueryCapture where alignment _ = alignment (0 :: Int32) {-# INLINE alignment #-}