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

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