Implement a correct bracket.

src/Parsing/TreeSitter.hs

@@ -4,9 +4,10 @@ module Parsing.TreeSitter
 , parseToAST
 ) where
 
-import Prologue
+import Prologue hiding (catchError, throwError)
 
 import Control.Concurrent.Async
+import Control.Exception (throwIO)
 import Control.Monad
 import Control.Monad.Effect
 import Control.Monad.IO.Class
@@ -20,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
@@ -59,10 +61,22 @@ runParser parser blobSource  = unsafeUseAsCStringLen (sourceBytes blobSource) $
                 runM (fmap Just (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, Members '[Exc SomeException, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
-parseToAST (Milliseconds s) language Blob{..} = liftIO $ bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
+parseToAST :: (Bounded grammar, Enum grammar, Member 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 -> liftIO $ do
   let parserTimeout = s * 1000
 
   TS.ts_parser_halt_on_error parser (CBool 1)

src/Semantic/IO.hs

@@ -1,35 +1,36 @@
 {-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.IO
-( readFile
-, readFilePair
-, isDirectory
-, readBlobPairsFromHandle
-, readBlobsFromHandle
-, readProjectFromPaths
-, readBlobsFromDir
-, findFiles
-, languageForFilePath
-, NoLanguageForBlob(..)
-, noLanguageForBlob
-, readBlob
-, readBlobs
-, readBlobPairs
-, readProject
-, findFilesInDir
-, write
-, Handle(..)
-, getHandle
-, IO.IOMode(..)
-, stdin
-, stdout
-, stderr
-, openFileForReading
-, Source(..)
-, Destination(..)
-, Files
-, runFiles
-, rethrowing
-) where
+  ( Destination(..)
+  , Files
+  , Handle(..)
+  , 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
+  , write
+  ) where
 
 import qualified Control.Exception as Exc
 import           Control.Monad.Effect
@@ -274,31 +275,6 @@ catchException :: ( Exc.Exception e
                -> Eff r a
 catchException m handler = interpose pure (\ m yield -> send (Exc.try m) >>= either handler yield) m
 
--- type Arrow m (effects :: [* -> *]) a b = a -> m effects b
--- raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b
--- send :: (Effectful m, Member eff e) => eff b -> m e b
--- interpose :: (Member eff e, Effectful m)
---           => Arrow m e a b
---           -> (forall v. eff v -> Arrow m e v b -> m e b)
---           -> m e a -> m e b
-
-masking :: Member IO r => Eff r a -> Eff r a
-masking = interpose pure $ \m yield -> do
-  res <- send (Exc.mask_ m)
-  yield res
-
-bracket' :: (Members [Exc SomeException, IO] r)
-         => Eff r a
-         -> (a -> Eff r b)
-         -> (a -> Eff r c)
-         -> Eff r c
-bracket' before after thing = do
-  a <- before
-  r <- thing a `catchError` (\(SomeException e) -> after a *> throwError (SomeException e))
-  r <$ after a
-
-
-
 -- | 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