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

src/Parsing/TreeSitter.hs

@@ -7,7 +7,10 @@ module Parsing.TreeSitter
 import Prologue
 
 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.Blob
 import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
@@ -18,6 +21,7 @@ import Data.Term
 import Foreign
 import Foreign.C.Types (CBool (..))
 import Foreign.Marshal.Array (allocaArray)
+import Semantic.IO hiding (Source)
 import System.Timeout
 
 import qualified TreeSitter.Language as TS
@@ -27,50 +31,65 @@ import qualified TreeSitter.Tree as TS
 
 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
       let acquire = do
-            dbg "Starting parse"
             -- 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
 
       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
             if treePtr == nullPtr
-              then pure Nothing
+              then pure Failed
               else do
                 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)
 
+-- | 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.
 -- 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
 
-  TS.ts_parser_halt_on_error parser (CBool 1)
+  liftIO $ do
-  TS.ts_parser_set_language parser language
+    TS.ts_parser_halt_on_error parser (CBool 1)
+    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.
-  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)

src/Semantic/CLI.hs

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

src/Semantic/IO.hs

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

src/Semantic/Task.hs

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