X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FCompat.hs;h=12031c34dff77d8f44f4245feeecbf23063844bd;hb=c7db2307c2d3dcc310fa5241756c2fbca7d00eea;hp=a68f74158bb95baa85d5965556eecaf5689c1044;hpb=f14d6c859ce68ec2d73503cbe03e205108df444d;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs
index a68f741..12031c3 100644
--- a/src/Language/Haskell/LSP/Test/Compat.hs
+++ b/src/Language/Haskell/LSP/Test/Compat.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
 -- For some reason ghc warns about not using
 -- Control.Monad.IO.Class but it's needed for
 -- MonadIO
@@ -7,19 +7,30 @@ module Language.Haskell.LSP.Test.Compat where
 
 import Data.Maybe
 import System.IO
+import Language.Haskell.LSP.Types
 
 #if MIN_VERSION_process(1,6,3)
+-- We have to hide cleanupProcess for process-1.6.3.0
+-- cause it is in the public api for 1.6.3.0 versions
+-- shipped with ghc >= 8.6 and < 8.6.4
+import System.Process hiding (getPid, cleanupProcess, withCreateProcess)
 # if MIN_VERSION_process(1,6,4)
-import System.Process hiding (getPid, cleanupProcess)
-import qualified System.Process (getPid, cleanupProcess)
+import qualified System.Process (getPid, cleanupProcess, withCreateProcess)
 # else
-import System.Process hiding (getPid)
+import Foreign.C.Error
+import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
+
 import qualified System.Process (getPid)
+import qualified Control.Exception as C
 # endif
 #else
-import System.Process
-import System.Process.Internals
 import Control.Concurrent.MVar
+import Foreign.C.Error
+import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
+import System.Process hiding (withCreateProcess)
+import System.Process.Internals
+
+import qualified Control.Exception as C
 #endif
 
 #ifdef mingw32_HOST_OS
@@ -59,23 +70,51 @@ getProcessID p = fromIntegral . fromJust <$> getProcessID' p
       _ -> return Nothing
 #endif
 
-cleanupRunningProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
-cleanupRunningProcess p@(_, _, _, ph) =
-  getProcessExitCode ph >>= maybe (cleanupProcess p) (const $ return ())
+cleanupProcess
+  :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
+
+withCreateProcess
+  :: CreateProcess
+  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
+  -> IO a
 
-cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
 #if MIN_VERSION_process(1,6,4)
+
 cleanupProcess = System.Process.cleanupProcess
+
+withCreateProcess = System.Process.withCreateProcess
+
 #else
-cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do
 
-    terminateProcess ph
+cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do
+    -- We ignore the spurious "permission denied" error in windows:
+    --   see https://github.com/haskell/process/issues/110
+    ignorePermDenied $ terminateProcess ph
     -- Note, it's important that other threads that might be reading/writing
     -- these handles also get killed off, since otherwise they might be holding
     -- the handle lock and prevent us from closing, leading to deadlock.
-    maybe (return ()) hClose mb_stdin
+    maybe (return ()) (ignoreSigPipe . hClose) mb_stdin
     maybe (return ()) hClose mb_stdout
     maybe (return ()) hClose mb_stderr
 
     return ()
+  where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE
+        ignorePermDenied = ignoreIOError PermissionDenied eACCES
+    
+ignoreIOError :: IOErrorType -> Errno -> IO () -> IO ()
+ignoreIOError ioErrorType errno =
+  C.handle $ \e -> case e of
+                     IOError { ioe_type  = iot
+                             , ioe_errno = Just ioe }
+                       | iot == ioErrorType && Errno ioe == errno -> return ()
+                     _ -> C.throwIO e
+
+withCreateProcess c action =
+  C.bracket (createProcess c) cleanupProcess
+            (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
+
 #endif
+
+
+lspTestClientInfo :: ClientInfo
+lspTestClientInfo = ClientInfo "lsp-test" (Just CURRENT_PACKAGE_VERSION)