Merge remote-tracking branch 'origin/master' into grpc-trees

src/Parsing/TreeSitter.hs

@@ -4,25 +4,26 @@ module Parsing.TreeSitter
 , parseToAST
 ) where
 
-import Prologue
+import Prologue hiding (bracket)
+
+import           Control.Concurrent.Async
+import qualified Control.Exception as Exc (bracket)
+import           Control.Monad.Effect
+import           Control.Monad.Effect.Exception
+import           Control.Monad.Effect.Trace
+import           Control.Monad.IO.Class
+import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)
+import           Foreign
+import           Foreign.C.Types (CBool (..))
+import           Foreign.Marshal.Array (allocaArray)
+import           System.Timeout
 
-import Control.Concurrent.Async
-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)
 import Data.Range
 import Data.Source
 import Data.Span
 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
 import qualified TreeSitter.Node as TS
@@ -53,24 +54,12 @@ runParser parser blobSource  = unsafeUseAsCStringLen (sourceBytes blobSource) $
                 TS.ts_tree_root_node_p treePtr rootPtr
                 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
+      Exc.bracket acquire release go)
 
 -- | Parse 'Source' with the given 'TS.Language' and return its AST.
 -- Returns Nothing if the operation timed out.
 parseToAST :: (Bounded grammar, Enum grammar, Member IO effects, Member Trace 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
 
   liftIO $ do

src/Semantic/IO.hs

@@ -6,7 +6,6 @@ module Semantic.IO
 , IO.IOMode(..)
 , NoLanguageForBlob(..)
 , Source(..)
-, catchException
 , findFiles
 , findFilesInDir
 , getHandle
@@ -34,7 +33,6 @@ module Semantic.IO
 , write
 ) where
 
-import qualified Control.Exception as Exc
 import           Control.Monad.Effect
 import           Control.Monad.Effect.Exception
 import           Control.Monad.IO.Class
@@ -231,23 +229,3 @@ runFiles = interpret $ \ files -> case files of
   FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs)
   Write (ToPath path)                   builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
   Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)
-
-
--- | Catch exceptions in 'IO' actions embedded in 'Eff', handling them with the passed function.
---
---   Note that while the type allows 'IO' to occur anywhere within the effect list, it must actually occur at the end to be able to run the computation.
-catchException :: ( Exc.Exception e
-                  , Member IO r
-                  )
-               => Eff r a
-               -> (e -> Eff r a)
-               -> Eff r a
-catchException m handler = interpose pure (\ m yield -> send (Exc.try m) >>= either handler yield) m
-
--- | Lift an 'IO' action into 'Eff', catching and rethrowing any exceptions it throws into an 'Exc' effect.
-rethrowing :: ( Member (Exc SomeException) r
-              , Member IO r
-              )
-           => IO a
-           -> Eff r a
-rethrowing m = catchException (liftIO m) (throwError . toException @SomeException)

test/Rendering/TOC/Spec.hs

@@ -2,7 +2,7 @@
 module Rendering.TOC.Spec (spec) where
 
 import Analysis.Declaration
-import Data.Aeson
+import Data.Aeson hiding (defaultOptions)
 import Data.Bifunctor
 import Data.Bifunctor.Join
 import Data.Diff
@@ -23,6 +23,7 @@ import Prelude
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
 import Rendering.TOC
+import Semantic.Config
 
 import SpecHelpers
 
@@ -102,7 +103,7 @@ spec = parallel $ do
 
     it "properly slices source blob that starts with a newline and has multi-byte chars" $ do
       sourceBlobs <- blobsForPaths (both "javascript/toc/starts-with-newline.js" "javascript/toc/starts-with-newline.js")
-      diff <- runTask $ diffWithParser rubyParser sourceBlobs
+      diff <- runTaskWithOptions (defaultOptions { optionsLogLevel = Nothing }) $ diffWithParser rubyParser sourceBlobs
       diffTOC diff `shouldBe` []
 
     prop "inserts of methods and functions are summarized" . forAll ((not . isMethodOrFunction . Prelude.snd) `filterT` tiers) $
@@ -150,7 +151,7 @@ spec = parallel $ do
 
     it "produces JSON output if there are parse errors" $ do
       blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.X.rb")
-      output <- runTask (runDiff ToCDiffRenderer [blobs])
+      output <- runTaskWithOptions (defaultOptions { optionsLogLevel = Nothing }) (runDiff ToCDiffRenderer [blobs])
       runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
 
     it "ignores anonymous functions" $ do

vendor/effects

@@ -1 +1 @@
-Subproject commit 5db3a4f18ee8a2bf97762a9846b76ca21383126e
+Subproject commit 8181375d6386de302a8c9807dad2f096e8d490aa

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit 0b065125cc1318a3daa65dc26819d3be97286688
+Subproject commit 643f8a2856f9d9a4cf25f3b0eb844aa46aafc535