Use Tree-sitter's built-in timeout API instead of a separate timeout thread

src/Parsing/TreeSitter.hs

@@ -6,7 +6,6 @@ module Parsing.TreeSitter
 
 import Prologue hiding (bracket)
 
-import           Control.Concurrent.Async
 import qualified Control.Exception as Exc (bracket)
 import           Control.Effect
 import           Control.Effect.Resource
@@ -60,7 +59,6 @@ parseToAST :: ( Bounded grammar
               , Carrier sig m
               , Enum grammar
               , Member Resource sig
-              , Member Timeout sig
               , Member Trace sig
               , MonadIO m
               )
@@ -69,25 +67,15 @@ parseToAST :: ( Bounded grammar
            -> Blob
            -> m (Maybe (AST [] grammar))
 parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
-  liftIO $ do
+  result <- liftIO $ do
+    let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
+    TS.ts_parser_set_timeout_micros parser timeoutMicros
     TS.ts_parser_halt_on_error parser (CBool 1)
     TS.ts_parser_set_language parser language
-
-  trace $ "tree-sitter: beginning parsing " <> blobPath
-
-  parsing <- liftIO . async $ runParser parser blobSource
-
-  -- Kick the parser off asynchronously and wait according to the provided timeout.
-  res <- timeout parseTimeout $ liftIO (wait parsing)
-
-  case res of
-    Just Failed          -> Nothing  <$ trace ("tree-sitter: parsing failed " <> blobPath)
-    Just (Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath)
-    Nothing -> do
-      trace $ "tree-sitter: parsing timed out " <> blobPath
-      liftIO (TS.ts_parser_set_enabled parser (CBool 0))
-      Nothing <$ liftIO (wait parsing)
-
+    runParser parser blobSource
+  case result of
+    Failed          -> Nothing  <$ trace ("tree-sitter: parsing failed " <> blobPath)
+    (Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath)
 
 toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
 toAST node@TS.Node{..} = do

test/Semantic/IO/Spec.hs

@@ -11,11 +11,6 @@ import System.IO (IOMode (..))
 import Parsing.TreeSitter
 import System.Timeout
 
-import qualified TreeSitter.Language as TS
-import qualified TreeSitter.Node as TS
-import qualified TreeSitter.Parser as TS
-import qualified TreeSitter.Tree as TS
-
 import Data.Blob
 import Data.Handle
 import SpecHelpers hiding (readFile)
@@ -79,24 +74,6 @@ spec = parallel $ do
       h <- openFileForReading "test/fixtures/cli/diff-null-both-sides.json"
       readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
 
-  describe "cancelable parsing" $
-    it "should be cancelable asynchronously" $ do
-      p <- TS.ts_parser_new
-
-      churn <- async $ do
-        TS.ts_parser_loop_until_cancelled p nullPtr nullPtr 0
-        pure True
-
-      res <- timeout 2500 (wait churn)
-      res `shouldBe` Nothing
-
-      TS.ts_parser_set_enabled p (CBool 0)
-      done <- timeout 2500 (wait churn)
-
-      done `shouldBe` (Just True)
-
-      TS.ts_parser_delete p
-
   describe "readBlobsFromHandle" $ do
     it "returns blobs for valid JSON encoded parse input" $ do
       h <- openFileForReading "test/fixtures/cli/parse.json"

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit 53dbe815fd85726484294833dfaece544d5f423d
+Subproject commit 3996ccfbe7b2a9efbfae8acab034393dfe6937cf