Merge pull request #303 from github/safer-exceptions-over-tree-sitter-ffi

Use Exception.try and throw to handle errors from tree-sitter FFI.

src/Control/Carrier/Parse/Measured.hs

@@ -60,13 +60,13 @@ runParser blob@Blob{..} parser = case parser of
     time "parse.tree_sitter_ast_parse" languageTag $ do
       config <- asks config
       parseToAST (configTreeSitterParseTimeout config) language blob
-        >>= either (trace >=> const (throwError (SomeException ParserTimedOut))) pure
+        >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure
 
   UnmarshalParser language ->
     time "parse.tree_sitter_ast_parse" languageTag $ do
       config <- asks config
       parseToPreciseAST (configTreeSitterParseTimeout config) language blob
-        >>= either (trace >=> const (throwError (SomeException ParserTimedOut))) pure
+        >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure
 
   AssignmentParser    parser assignment -> runAssignment Assignment.assign    parser blob assignment
   DeterministicParser parser assignment -> runAssignment Deterministic.assign parser blob assignment

src/Control/Carrier/Parse/Simple.hs

@@ -51,11 +51,11 @@ runParser
 runParser timeout blob@Blob{..} parser = case parser of
   ASTParser language ->
     parseToAST timeout language blob
-      >>= either (throwError . SomeException . ParseFailure) pure
+      >>= either (throwError . SomeException) pure
 
   UnmarshalParser language ->
     parseToPreciseAST timeout language blob
-      >>= either (throwError . SomeException . ParseFailure) pure
+      >>= either (throwError . SomeException) pure
 
   AssignmentParser    parser assignment ->
     runParser timeout blob parser >>= either (throwError . toException) pure . Assignment.assign    blobSource assignment

src/Parsing/TreeSitter.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE DataKinds, GADTs, LambdaCase, ScopedTypeVariables, TypeOperators #-}
 module Parsing.TreeSitter
-( Duration(..)
+( TSParseException (..)
+, Duration(..)
 , parseToAST
 , parseToPreciseAST
 ) where
@@ -10,6 +11,7 @@ import Prologue
 import           Control.Effect.Fail
 import           Control.Effect.Lift
 import           Control.Effect.Reader
+import qualified Control.Exception as Exc
 import           Foreign
 import           Foreign.C.Types (CBool (..))
 import           Foreign.Marshal.Array (allocaArray)
@@ -29,6 +31,12 @@ import qualified TreeSitter.Parser as TS
 import qualified TreeSitter.Tree as TS
 import qualified TreeSitter.Unmarshal as TS
 
+data TSParseException
+  = ParserTimedOut
+  | IncompatibleVersions
+  | UnmarshalFailure String
+    deriving (Eq, Show, Generic)
+
 -- | Parse a 'Blob' with the given 'TS.Language' and return its AST.
 -- Returns 'Nothing' if the operation timed out.
 parseToAST :: ( Bounded grammar
@@ -38,8 +46,8 @@ parseToAST :: ( Bounded grammar
            => Duration
            -> Ptr TS.Language
            -> Blob
-           -> m (Either String (AST [] grammar))
-parseToAST parseTimeout language blob = runParse parseTimeout language blob (fmap Right . anaM toAST <=< peek)
+           -> m (Either TSParseException  (AST [] grammar))
+parseToAST parseTimeout language blob = runParse parseTimeout language blob (anaM toAST <=< peek)
 
 parseToPreciseAST
   :: ( MonadIO m
@@ -48,20 +56,27 @@ parseToPreciseAST
   => Duration
   -> Ptr TS.Language
   -> Blob
-  -> m (Either String (t Loc))
+  -> m (Either TSParseException (t Loc))
 parseToPreciseAST parseTimeout language blob = runParse parseTimeout language blob $ \ rootPtr ->
   TS.withCursor (castPtr rootPtr) $ \ cursor ->
     runM (runFail (runReader cursor (runReader (Source.bytes (blobSource blob)) (TS.peekNode >>= TS.unmarshalNode))))
+      >>= either (Exc.throw . UnmarshalFailure) pure
+
+instance Exception TSParseException where
+  displayException = \case
+    ParserTimedOut -> "tree-sitter: parser timed out"
+    IncompatibleVersions -> "tree-sitter: incompatible versions"
+    UnmarshalFailure s -> "tree-sitter: unmarshal failure - " <> show s
 
 runParse
   :: MonadIO m
   => Duration
   -> Ptr TS.Language
   -> Blob
-  -> (Ptr TS.Node -> IO (Either String a))
-  -> m (Either String a)
+  -> (Ptr TS.Node -> IO a)
+  -> m (Either TSParseException a)
 runParse parseTimeout language Blob{..} action =
-  liftIO . TS.withParser language $ \ parser -> do
+  liftIO . Exc.tryJust fromException . TS.withParser language $ \ parser -> do
     let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
     TS.ts_parser_set_timeout_micros parser timeoutMicros
     TS.ts_parser_halt_on_error parser (CBool 1)
@@ -69,11 +84,11 @@ runParse parseTimeout language Blob{..} action =
     if compatible then
       TS.withParseTree parser (Source.bytes blobSource) $ \ treePtr -> do
         if treePtr == nullPtr then
-          pure (Left "tree-sitter: null root node")
+          Exc.throw ParserTimedOut
         else
           TS.withRootNode treePtr action
     else
-      pure (Left "tree-sitter: incompatible versions")
+      Exc.throw IncompatibleVersions
 
 toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
 toAST node@TS.Node{..} = do