github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 09:55:52 +03:00
Code Issues Projects Releases Wiki Activity

Rely on the TS definition of withParser.

Browse Source
This commit is contained in:
Rob Rix 2019-09-26 12:45:50 -04:00
parent c399f0d637
commit 2745c69aa1
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 7 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/Parsing/TreeSitter.hs
View File

@ -6,7 +6,6 @@ module Parsing.TreeSitter
import Prologue hiding (bracket) import Prologue hiding (bracket)
import Control.Effect.Resource
import Control.Effect.Trace import Control.Effect.Trace
import qualified Control.Exception as Exc (bracket) import qualified Control.Exception as Exc (bracket)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
@ -52,7 +51,6 @@ runParserToAST parser blobSource = unsafeUseAsCStringLen (Source.bytes blobSourc
parseToAST :: ( Bounded grammar parseToAST :: ( Bounded grammar
, Carrier sig m , Carrier sig m
, Enum grammar , Enum grammar
, Member Resource sig
, Member Trace sig , Member Trace sig
, MonadIO m , MonadIO m
) )
@ -60,16 +58,16 @@ parseToAST :: ( Bounded grammar
-> Ptr TS.Language -> Ptr TS.Language
-> Blob -> Blob
-> m (Maybe (AST [] grammar)) -> m (Maybe (AST [] grammar))
parseToAST parseTimeout language b@Blob{..} = withParser language $ \ parser -> do parseToAST parseTimeout language b@Blob{..} = do
compatible <- liftIO $ do result <- liftIO . TS.withParser language $ \ parser -> do
let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
TS.ts_parser_set_timeout_micros parser timeoutMicros TS.ts_parser_set_timeout_micros parser timeoutMicros
TS.ts_parser_halt_on_error parser (CBool 1) TS.ts_parser_halt_on_error parser (CBool 1)
TS.ts_parser_set_language parser language compatible <- TS.ts_parser_set_language parser language
result <- if compatible then if compatible then
liftIO $ runParserToAST parser blobSource runParserToAST parser blobSource
else else
Nothing <$ trace "tree-sitter: incompatible versions" pure Nothing
case result of case result of
Nothing -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath b) Nothing -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath b)
Just ast -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath b) Just ast -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath b)
@ -92,12 +90,3 @@ nodeRange TS.Node{..} = Range (fromIntegral nodeStartByte) (fromIntegral nodeEnd
nodeSpan :: TS.Node -> Span nodeSpan :: TS.Node -> Span
nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint) nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint)
where pointPos TS.TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn) where pointPos TS.TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn)
withParser :: (Carrier sig m, Member Resource sig, MonadIO m) => Ptr TS.Language -> (Ptr TS.Parser -> m a) -> m a
withParser language action = bracket
(liftIO TS.ts_parser_new)
(liftIO . TS.ts_parser_delete)
$ \ parser -> do
_ <- liftIO (TS.ts_parser_set_language parser language)
action parser