src/Language/Haskell/LSP/Test/Compat.hs

   1 {-# LANGUAGE CPP #-}
   2 -- For some reason ghc warns about not using
   3 -- Control.Monad.IO.Class but it's needed for
   4 -- MonadIO
   5 {-# OPTIONS_GHC -Wunused-imports #-}
   6 module Language.Haskell.LSP.Test.Compat where
   7
   8 import Data.Maybe
   9 import System.IO
  10
  11 #if MIN_VERSION_process(1,6,3)
  12 -- We have to hide cleanupProcess for process-1.6.3.0
  13 -- cause it is in the public api for 1.6.3.0 versions
  14 -- shipped with ghc >= 8.6 and < 8.6.4
  15 import System.Process hiding (getPid, cleanupProcess, withCreateProcess)
  16 # if MIN_VERSION_process(1,6,4)
  17 import qualified System.Process (getPid, cleanupProcess, withCreateProcess)
  18 # else
  19 import Foreign.C.Error
  20 import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
  21
  22 import qualified System.Process (getPid)
  23 import qualified Control.Exception as C
  24 # endif
  25 #else
  26 import Control.Concurrent.MVar
  27 import Foreign.C.Error
  28 import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
  29 import System.Process hiding (withCreateProcess)
  30 import System.Process.Internals
  31
  32 import qualified Control.Exception as C
  33 #endif
  34
  35 #ifdef mingw32_HOST_OS
  36 import qualified System.Win32.Process
  37 #else
  38 import qualified System.Posix.Process
  39 #endif
  40
  41
  42 getCurrentProcessID :: IO Int
  43 #ifdef mingw32_HOST_OS
  44 getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId
  45 #else
  46 getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID
  47 #endif
  48
  49 getProcessID :: ProcessHandle -> IO Int
  50 getProcessID p = fromIntegral . fromJust <$> getProcessID' p
  51   where
  52 #if MIN_VERSION_process(1,6,3)
  53   getProcessID' = System.Process.getPid
  54 #else
  55 #if MIN_VERSION_process(1,6,0)
  56   getProcessID' (ProcessHandle mh _ _) = do
  57 #else
  58   getProcessID' (ProcessHandle mh _) = do
  59 #endif
  60     p_ <- readMVar mh
  61     case p_ of
  62 #ifdef mingw32_HOST_OS
  63       OpenHandle h -> do
  64         pid <- System.Win32.Process.getProcessId h
  65         return $ Just pid
  66 #else
  67       OpenHandle pid -> return $ Just pid
  68 #endif
  69       _ -> return Nothing
  70 #endif
  71
  72 cleanupRunningProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
  73 cleanupRunningProcess p@(_, _, _, ph) =
  74   getProcessExitCode ph >>= maybe (cleanupProcess p) (const $ return ())
  75
  76 cleanupProcess
  77   :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
  78
  79 withCreateProcess
  80   :: CreateProcess
  81   -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
  82   -> IO a
  83
  84 #if MIN_VERSION_process(1,6,4)
  85
  86 cleanupProcess = System.Process.cleanupProcess
  87
  88 withCreateProcess = System.Process.withCreateProcess
  89
  90 #else
  91
  92 cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do
  93     -- We ignore the spurious "permission denied" error in windows:
  94     --   see https://github.com/haskell/process/issues/110
  95     ignorePermDenied $ terminateProcess ph
  96     -- Note, it's important that other threads that might be reading/writing
  97     -- these handles also get killed off, since otherwise they might be holding
  98     -- the handle lock and prevent us from closing, leading to deadlock.
  99     maybe (return ()) (ignoreSigPipe . hClose) mb_stdin
 100     maybe (return ()) hClose mb_stdout
 101     maybe (return ()) hClose mb_stderr
 102
 103     return ()
 104   where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE
 105         ignorePermDenied = ignoreIOError PermissionDenied ePERM
 106
 107 ignoreIOError :: IOErrorType -> Errno -> IO () -> IO ()
 108 ignoreIOError ioErrorType errno =
 109   C.handle $ \e -> case e of
 110                      IOError { ioe_type  = iot
 111                              , ioe_errno = Just ioe }
 112                        | iot == ioErrorType && Errno ioe == errno -> return ()
 113                      _ -> C.throwIO e
 114
 115 withCreateProcess c action =
 116   C.bracket (createProcess c) cleanupProcess
 117             (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
 118
 119 #endif