Merge pull request #2211 from github/bracket-effect

Fix crash/race associated with `bracket` (#2207)

src/Parsing/TreeSitter.hs

@@ -9,7 +9,7 @@ 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.Resource
 import           Control.Monad.Effect.Trace
 import           Control.Monad.IO.Class
 import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)
@@ -57,8 +57,18 @@ runParser parser blobSource  = unsafeUseAsCStringLen (sourceBytes blobSource) $
 
 -- | Parse 'Source' with the given 'TS.Language' and return its AST.
 -- Returns Nothing if the operation timed out.
-parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Timeout effects, Member Trace effects, PureEffects effects) => Duration -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
-parseToAST parseTimeout language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
+parseToAST :: ( Bounded grammar
+              , Enum grammar
+              , Member (Lift IO) effects
+              , Member Resource effects
+              , Member Timeout effects
+              , Member Trace effects
+              )
+           => Duration
+           -> Ptr TS.Language
+           -> Blob
+           -> Eff effects (Maybe (AST [] grammar))
+parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
   liftIO $ do
     TS.ts_parser_halt_on_error parser (CBool 1)
     TS.ts_parser_set_language parser language

src/Semantic/REPL.hs

@@ -5,6 +5,7 @@ module Semantic.REPL
 ) where
 
 import Control.Abstract hiding (Continue, List, string)
+import Control.Monad.Effect.Resource
 import Control.Monad.IO.Class
 import Data.Abstract.Address.Precise as Precise
 import Data.Abstract.Environment as Env
@@ -70,7 +71,7 @@ runREPL prefs settings = interpret $ \case
 
 rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
 
-repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runTimeout (runM . runDistribute) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do
+repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do
   blobs <- catMaybes <$> traverse IO.readFile (flip File (Language.reflect proxy) <$> paths)
   package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
   modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package)

src/Semantic/Task.hs

@@ -61,6 +61,7 @@ import           Control.Monad
 import           Control.Monad.Effect
 import           Control.Monad.Effect.Exception
 import           Control.Monad.Effect.Reader
+import           Control.Monad.Effect.Resource
 import           Control.Monad.Effect.Trace
 import           Data.Blob
 import           Data.Bool
@@ -98,6 +99,7 @@ type TaskEff = Eff '[ Task
                     , Telemetry
                     , Exc SomeException
                     , Timeout
+                    , Resource
                     , Distribute
                     , Lift IO
                     ]
@@ -151,7 +153,8 @@ runTaskWithConfig options logger statter task = do
         run
           = runM
           . runDistribute
-          . runTimeout (runM . runDistribute)
+          . runResource (runM . runDistribute)
+          . runTimeout (runM . runDistribute . runResource (runM . runDistribute))
           . runError
           . runTelemetry logger statter
           . runTraceInTelemetry
@@ -186,7 +189,7 @@ instance Effect Task where
   handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k)
 
 -- | Run a 'Task' effect by performing the actions in 'IO'.
-runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a
+runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a
 runTaskF = interpret $ \ task -> case task of
   Parse parser blob -> runParser blob parser
   Analyze interpret analysis -> pure (interpret analysis)
@@ -208,7 +211,7 @@ data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut Fil
 instance Exception ParserCancelled
 
 -- | Parse a 'Blob' in 'IO'.
-runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term
+runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term
 runParser blob@Blob{..} parser = case parser of
   ASTParser language ->
     time "parse.tree_sitter_ast_parse" languageTag $ do
@@ -238,6 +241,7 @@ runParser blob@Blob{..} parser = case parser of
                          , Member Telemetry effs
                          , Member Timeout effs
                          , Member Trace effs
+                         , Member Resource effs
                          , PureEffects effs
                          )
                       => (Source -> assignment (Term (Sum syntaxes) Assignment.Location) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Location))

test/Examples.hs

@@ -50,6 +50,7 @@ main = withOptions opts $ \ config logger statter -> hspec . parallel $ do
           Left (SomeException e) -> case cast e of
             -- We have a number of known assignment timeouts, consider these pending specs instead of failing the build.
             Just (AssignmentTimedOut _ _) -> pendingWith $ show (displayException e)
+            Just (ParserTimedOut _ _) -> pendingWith $ show (displayException e)
             -- Other exceptions are true failures
             _ -> expectationFailure (show (displayException e))
           _ -> if file `elem` knownFailures

test/Rendering/TOC/Spec.hs

@@ -16,7 +16,7 @@ import Data.Sum
 import Data.Term
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
-import Data.Union
+import Data.Union hiding (forAll)
 import Diffing.Algorithm
 import Diffing.Interpreter
 import Prelude

vendor/effects

@@ -1 +1 @@
-Subproject commit 8ded4a64133ce77ddd2fc734f455753e62af0ad3
+Subproject commit e7858dacce6fbb43e76a49e4dbeff1f1815aa290

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit 7ee860f415959357ec031df93bc424b0f89dbe48
+Subproject commit 9c28ccf49be8bbc78635bb0927ae1ae43d2f580b