1
1
mirror of https://github.com/github/semantic.git synced 2024-12-24 07:25:44 +03:00

Merge branch 'master' into recursive-type-families-are-not-our-friends

This commit is contained in:
Rob Rix 2018-05-29 12:12:41 -04:00
commit f3649f30de
4 changed files with 70 additions and 49 deletions

View File

@ -7,7 +7,10 @@ module Parsing.TreeSitter
import Prologue import Prologue
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Monad import Control.Exception (throwIO)
import Control.Monad.Effect
import Control.Monad.Effect.Trace
import Control.Monad.IO.Class
import Data.AST (AST, Node (Node)) import Data.AST (AST, Node (Node))
import Data.Blob import Data.Blob
import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
@ -18,6 +21,7 @@ import Data.Term
import Foreign import Foreign
import Foreign.C.Types (CBool (..)) import Foreign.C.Types (CBool (..))
import Foreign.Marshal.Array (allocaArray) import Foreign.Marshal.Array (allocaArray)
import Semantic.IO hiding (Source)
import System.Timeout import System.Timeout
import qualified TreeSitter.Language as TS import qualified TreeSitter.Language as TS
@ -27,50 +31,65 @@ import qualified TreeSitter.Tree as TS
newtype Timeout = Milliseconds Int newtype Timeout = Milliseconds Int
-- Change this to putStrLn if you want to debug the locking/cancellation code. data Result grammar
-- TODO: Someday we should run this all in Eff so that we can 'trace'. = Failed
dbg :: String -> IO () | Succeeded (AST [] grammar)
dbg = const (pure ())
runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Maybe (AST [] grammar)) runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Result grammar)
runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do
alloca (\ rootPtr -> do alloca (\ rootPtr -> do
let acquire = do let acquire = do
dbg "Starting parse"
-- Change this to TS.ts_parser_loop_until_cancelled if you want to test out cancellation -- Change this to TS.ts_parser_loop_until_cancelled if you want to test out cancellation
TS.ts_parser_parse_string parser nullPtr source len TS.ts_parser_parse_string parser nullPtr source len
let release t let release t
| t == nullPtr = dbg "Parse failed" | t == nullPtr = pure ()
| otherwise = dbg "Parse completed" *> TS.ts_tree_delete t | otherwise = TS.ts_tree_delete t
let go treePtr = do let go treePtr = do
if treePtr == nullPtr if treePtr == nullPtr
then pure Nothing then pure Failed
else do else do
TS.ts_tree_root_node_p treePtr rootPtr TS.ts_tree_root_node_p treePtr rootPtr
fmap Just (peek rootPtr >>= anaM toAST) ptr <- peek rootPtr
Succeeded <$> anaM toAST ptr
bracket acquire release go) bracket acquire release go)
-- | The semantics of @bracket before after handler@ are as follows:
-- * Exceptions in @before@ and @after@ are thrown in IO.
-- * @after@ is called on IO exceptions in @handler@, and then rethrown in IO.
-- * If @handler@ completes successfully, @after@ is called
-- Call 'catchException' at the call site if you want to recover.
bracket' :: (Member IO r) => IO a -> (a -> IO b) -> (a -> Eff r c) -> Eff r c
bracket' before after action = do
a <- liftIO before
let cleanup = liftIO (after a)
res <- action a `catchException` (\(e :: SomeException) -> cleanup >> liftIO (throwIO e))
res <$ cleanup
-- | Parse 'Source' with the given 'TS.Language' and return its AST. -- | Parse 'Source' with the given 'TS.Language' and return its AST.
-- Returns Nothing if the operation timed out. -- Returns Nothing if the operation timed out.
parseToAST :: (Bounded grammar, Enum grammar) => Timeout -> Ptr TS.Language -> Blob -> IO (Maybe (AST [] grammar)) parseToAST :: (Bounded grammar, Enum grammar, Members '[Trace, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
let parserTimeout = s * 1000 let parserTimeout = s * 1000
liftIO $ do
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 TS.ts_parser_set_language parser language
parsing <- async (runParser parser blobSource) trace "tree-sitter: beginning parsing"
parsing <- liftIO . async $ runParser parser blobSource
-- Kick the parser off asynchronously and wait according to the provided timeout. -- Kick the parser off asynchronously and wait according to the provided timeout.
res <- timeout parserTimeout (wait parsing) res <- liftIO . timeout parserTimeout $ wait parsing
-- If we get a Nothing back, then we failed, so we need to disable the parser, which case res of
-- will let the call to runParser terminate, cleaning up appropriately Just Failed -> Nothing <$ trace "tree-sitter: parsing failed"
when (isNothing res) (TS.ts_parser_set_enabled parser (CBool 0)) Just (Succeeded ast) -> Just ast <$ trace "tree-sitter: parsing succeeded"
Nothing -> do
pure (join res) trace "tree-sitter: parsing timed out"
Nothing <$ liftIO (TS.ts_parser_set_enabled parser (CBool 0))
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)

View File

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct.
{-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-} {-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-}
module Semantic.CLI module Semantic.CLI
( main ( main

View File

@ -1,34 +1,35 @@
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.IO module Semantic.IO
( readFile ( Destination(..)
, readFilePair , Files
, isDirectory
, readBlobPairsFromHandle
, readBlobsFromHandle
, readProjectFromPaths
, readBlobsFromDir
, findFiles
, languageForFilePath
, NoLanguageForBlob(..)
, noLanguageForBlob
, readBlob
, readBlobs
, readBlobPairs
, readProject
, findFilesInDir
, write
, Handle(..) , Handle(..)
, getHandle
, IO.IOMode(..) , IO.IOMode(..)
, NoLanguageForBlob(..)
, Source(..)
, catchException
, findFiles
, findFilesInDir
, getHandle
, isDirectory
, languageForFilePath
, noLanguageForBlob
, openFileForReading
, readBlob
, readBlobPairs
, readBlobPairsFromHandle
, readBlobs
, readBlobsFromDir
, readBlobsFromHandle
, readFile
, readFilePair
, readProject
, readProjectFromPaths
, rethrowing
, runFiles
, stderr
, stdin , stdin
, stdout , stdout
, stderr , write
, openFileForReading
, Source(..)
, Destination(..)
, Files
, runFiles
, rethrowing
) where ) where
import qualified Control.Exception as Exc import qualified Control.Exception as Exc

View File

@ -195,7 +195,7 @@ runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Op
runParser blob@Blob{..} parser = case parser of runParser blob@Blob{..} parser = case parser of
ASTParser language -> ASTParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ time "parse.tree_sitter_ast_parse" languageTag $
IO.rethrowing (parseToAST defaultTimeout language blob) parseToAST defaultTimeout language blob
>>= maybeM (throwError (SomeException ParserTimedOut)) >>= maybeM (throwError (SomeException ParserTimedOut))
AssignmentParser parser assignment -> do AssignmentParser parser assignment -> do