ide-backend-server 0.9.0 → 0.10.0
raw patch · 13 files changed
+784/−55 lines, 13 filesdep +file-embeddep +tardep +zlibdep ~ghcdep ~ide-backend-commonbuild-type:Customsetup-changednew-uploader
Dependencies added: file-embed, tar, zlib
Dependency ranges changed: ghc, ide-backend-common
Files
- FilePathCaching.hs +13/−3
- GhcShim.hs +1/−1
- HsWalk.hs +12/−6
- Posix.hsc +197/−0
- RTS.hs +40/−0
- Run.hs +17/−7
- Server.hs +119/−32
- Setup.hs +194/−1
- ide-backend-rts/IdeBackendRTS.hs +126/−0
- ide-backend-rts/LICENSE +21/−0
- ide-backend-rts/Setup.hs +2/−0
- ide-backend-rts/ide-backend-rts.cabal +21/−0
- ide-backend-server.cabal +21/−5
FilePathCaching.hs view
@@ -1,6 +1,7 @@ module FilePathCaching ( MonadFilePathCaching(..) , mkFilePathPtr+ , extractEitherSpan , extractSourceSpan ) where @@ -46,15 +47,24 @@ Just key -> return $ FilePathPtr key -extractSourceSpan :: MonadFilePathCaching m => SrcSpan -> m EitherSpan-extractSourceSpan (RealSrcSpan srcspan) = do+extractEitherSpan :: MonadFilePathCaching m => SrcSpan -> m EitherSpan+extractEitherSpan (RealSrcSpan srcspan) = do key <- mkFilePathPtr $ unpackFS (srcSpanFile srcspan) return . ProperSpan $ SourceSpan key (srcSpanStartLine srcspan) (srcSpanStartCol srcspan) (srcSpanEndLine srcspan) (srcSpanEndCol srcspan)-extractSourceSpan (UnhelpfulSpan s) =+extractEitherSpan (UnhelpfulSpan s) = return . TextSpan $ fsToText s++extractSourceSpan:: MonadFilePathCaching m => RealSrcSpan -> m SourceSpan+extractSourceSpan srcspan = do+ key <- mkFilePathPtr $ unpackFS (srcSpanFile srcspan)+ return $ SourceSpan+ key+ (srcSpanStartLine srcspan) (srcSpanStartCol srcspan)+ (srcSpanEndLine srcspan) (srcSpanEndCol srcspan)+ fsToText :: FastString -> Text fsToText = Text.pack . unpackFS
GhcShim.hs view
@@ -50,7 +50,7 @@ #ifdef GHC_710 import GhcShim.GhcShim710 #else-#error "Unsupported GHC version"+#error "No GHC_* CPP flag specified, possibly using an unsupported GHC version" #endif #endif #endif
HsWalk.hs view
@@ -136,9 +136,15 @@ extractIdsResumeTc stRef $ go span return qq where+#ifdef GHC_AFTER_710_1+ go :: RealSrcSpan -> ExtractIdsM ()+ go span = do+ span' <- extractSourceSpan span+#else go :: SrcSpan -> ExtractIdsM () go span = do- ProperSpan span' <- extractSourceSpan span+ ProperSpan span' <- extractEitherSpan span+#endif dflags <- asks eIdsDynFlags linkEnv <- asks eIdsLinkEnv rdrEnv <- asks eIdsRdrEnv@@ -397,7 +403,7 @@ recordExpType :: SrcSpan -> Maybe Type -> ExtractIdsM (Maybe Type) recordExpType span (Just typ) = do- eitherSpan <- extractSourceSpan span+ eitherSpan <- extractEitherSpan span case eitherSpan of ProperSpan properSpan -> do prettyTyp <- tidyType typ >>= showTypeForUser@@ -455,7 +461,7 @@ -> m (IdPropPtr, Maybe IdScope) -- ^ Nothing if imported but no GlobalRdrElt idInfoForName dflags name idIsBinder mElt mCurrent home = do scope <- constructScope- idDefSpan <- extractSourceSpan (Name.nameSrcSpan name)+ idDefSpan <- extractEitherSpan (Name.nameSrcSpan name) let mod = if isLocal scope then fromJust mCurrent@@ -501,8 +507,8 @@ extractImportInfo :: [RdrName.ImportSpec] -> m (GHC.ModuleName, EitherSpan, String) extractImportInfo (RdrName.ImpSpec decl item:_) = do span <- case item of- RdrName.ImpAll -> extractSourceSpan (RdrName.is_dloc decl)- RdrName.ImpSome _explicit loc -> extractSourceSpan loc+ RdrName.ImpAll -> extractEitherSpan (RdrName.is_dloc decl)+ RdrName.ImpSome _explicit loc -> extractEitherSpan loc return ( RdrName.is_mod decl , span@@ -563,7 +569,7 @@ -> IsBinder -> Located Name -> ExtractIdsM (Maybe Type) recordName mkSpanInfo idIsBinder (L span name) = do- span' <- extractSourceSpan span+ span' <- extractEitherSpan span case span' of ProperSpan sourceSpan -> do dflags <- getDynFlags
+ Posix.hsc view
@@ -0,0 +1,197 @@+{-++Modified by Michael Sloan, FP Complete, in 2015++Copyright 2012-2013 Google Inc. All Rights Reserved.+Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at+ http://www.apache.org/licenses/LICENSE-2.0+Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+-}++{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- | Modified by Michael Sloan, FP Complete, in 2015+--+-- Based on https://github.com/mzero/plush/blob/ffa6c84f7bcb7bd57079e9a519e2bdc1ae07b4be/src/System/Posix/Missing.hsc+module Posix (+ dupFd, dupFdCloseOnExec,++ loginTerminal,+ setControllingTerminal,++ getArg0,+ executeFile0,+ -- * From Plush.Run.Posix.IO+ write,+ readChunk+ ) where++import Control.Applicative ((<$>))+import Control.Arrow (second)+import Control.Exception (throwIO)+import Control.Monad (when, void)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Internal as BS (createAndTrim)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Foreign (withArray0, withMany)+import Foreign.C (CInt(..), CString, CULong(..),+ throwErrnoIfMinus1, throwErrnoIfMinus1_, throwErrnoPathIfMinus1_)+import Foreign.Ptr (Ptr, nullPtr, castPtr, plusPtr)+import Foreign.Ptr (nullPtr, Ptr)+import Foreign.Safe (alloca, peek, peekElemOff)+import GHC.Foreign (peekCString)+import GHC.IO.Device (SeekMode(SeekFromEnd, AbsoluteSeek))+import GHC.IO.Encoding (getFileSystemEncoding)+import GHC.IO.Exception (IOErrorType(UnsupportedOperation))+import System.IO.Error (ioeGetErrorType, catchIOError)+import System.Posix.IO (fdReadBuf, fdSeek, fdWriteBuf, setFdOption, FdOption(CloseOnExec))+import System.Posix.Internals (c_fcntl_write, FD, withFilePath)+import System.Posix.Process.Internals (pPrPr_disableITimers)+import System.Posix.Types (Fd(Fd))++#include "HsUnix.h"++-- | This is like 'dup', but takes an extra argument. The new file descriptor+-- will be the lowest free file descriptor not less than the second argument.+-- The 'CloseOnExec' flag (FD_CLOEXEC) will be cleared on the new descriptor.+dupFd :: Fd -> Fd -> IO Fd+dupFd = dupFdViaFcntl (#const F_DUPFD)++-- | Same as 'dupFd', but the 'CloseOnExec' flag (FD_CLOEXEC) will be set.+dupFdCloseOnExec :: Fd -> Fd -> IO Fd+-- dupFdCloseOnExec = dupFdViaFcntl (#const F_DUPFD_CLOEXEC)+ -- While this is POSIX, is is relatively new, and many systems do not+ -- support this operation. The following code simulates it.+dupFdCloseOnExec src base = do+ dest <- dupFd src base+ setFdOption dest CloseOnExec True+ return dest++dupFdViaFcntl :: CInt -> Fd -> Fd -> IO Fd+dupFdViaFcntl op (Fd srcFd) (Fd minFd) = Fd `fmap`+ throwErrnoIfMinus1 "dupFdViaFcntl"+ (c_fcntl_write srcFd op (fromIntegral minFd))++-- | Prepares for login on the tty, which should be a real tty or the slave+-- from a call to `openPseudoTerminal`. A new session will be started, the tty+-- will become the controlling terminal, and the tty is dup'd down to become+-- the standard in, out and err FDs.+loginTerminal :: Fd -> IO ()++#ifdef HAVE_OPENPTY+ -- In theory this should be testing HAVE_LOGIN_TTY, but that doesn't exist.+ -- The calls login_tty, openpty, and forkpty are part of the same BSD module+ -- and so are all generally present together or not.+loginTerminal (Fd ttyFd) =+ throwErrnoIfMinus1_ "loginTerminal" (c_login_tty ttyFd)++foreign import ccall unsafe "login_tty"+ c_login_tty :: CInt -> IO CInt++#else+loginTerminal tty = do+ _ <- createSession+ setControllingTerminal tty+ _ <- dupTo tty stdInput+ _ <- dupTo tty stdOutput+ _ <- dupTo tty stdError+ when (tty > stdError) $ closeFd tty+#endif++-- | Set the controlling terminal of the process. The tty should be a real tty+-- or the slave from a call to 'openPseudoTerminal'.+setControllingTerminal :: Fd -> IO ()++#ifdef TIOCSCTTY+setControllingTerminal (Fd ttyfd) =+ throwErrnoIfMinus1_ "setControllingTerminal"+ (ioctl ttyfd (#const TIOCSCTTY) nullPtr)++foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt+#else+-- POSIX doesn't spec how to set the controlling terminal! The ioctl TIOSCTTY+-- method above is generally available, but some systems don't have it. The+-- second most common way to set the controlling terminal is to open it when no+-- other terminal is opened in the process. That is what this alternative+-- implementation does. Be forewarned that they may be systems that use yet some+-- third unknown method.+setControllingTerminal tty = do+ ttyName <- getTerminalName tty+ when (tty /= stdInput) $ closeFd stdInput+ when (tty /= stdOutput) $ closeFd stdOutput+ when (tty /= stdError) $ closeFd stdError+ openFd ttyName ReadWrite Nothing defaultFileFlags >>= closeFd+#endif++-- | Return @argv[0]@ as passed to the program on invocation. Unlike+-- 'getProgName', this is the raw value passed to the process. It may, or may+-- not, have anything to do with the name of the running executable!+getArg0 :: IO String+getArg0 =+ alloca $ \ p_argc ->+ alloca $ \ p_argv -> do+ getProgArgv p_argc p_argv+ argv <- peek p_argv+ enc <- getFileSystemEncoding+ peekElemOff argv 0 >>= peekCString enc++foreign import ccall unsafe "getProgArgv"+ getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()+++-- | Like 'executeFile', but allow for expressly setting @argv[0]@+-- For simplicity, this version has no path search option, and always takes an+-- environment. If incorporating into System.Posix.Process, the signature+-- should better match 'executeFile'.+executeFile0 :: FilePath -> String -> [String] -> [(String, String)] -> IO a+executeFile0 path cmd args env = do+ withFilePath path $ \s ->+ withMany withFilePath (cmd:args) $ \cstrs ->+ withArray0 nullPtr cstrs $ \arg_arr ->+ let env' = map (\ (name, val) -> name ++ ('=' : val)) env in+ withMany withFilePath env' $ \cenv ->+ withArray0 nullPtr cenv $ \env_arr -> do+ pPrPr_disableITimers+ throwErrnoPathIfMinus1_ "executeFile" path+ (c_execve s arg_arr env_arr)+ return undefined -- never reached++foreign import ccall unsafe "execve"+ c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt++-- Copied from Plush.Run.Posix+-- https://github.com/mzero/plush/blob/ffa6c84f7bcb7bd57079e9a519e2bdc1ae07b4be/src/Plush/Run/Posix.hs++-- | Based on code for readLoop, but instead expects a blocking Fd.+readChunk :: Fd -> IO BS.ByteString+readChunk fd =+ BS.createAndTrim bufSize $ \buf ->+ fmap fromIntegral (fdReadBuf fd buf (fromIntegral bufSize))+ where+ bufSize = 4096++-- | 'write' for 'IO': Seek to the end, and write.+--+-- Modified to take a strict bytestring+write :: Fd -> BS.ByteString -> IO ()+write fd bs = unsafeUseAsCStringLen bs writeBuf+ where+ writeBuf (p, n) | n > 0 = do+ ignoreUnsupportedOperation $ fdSeek fd SeekFromEnd 0+ m <- fromIntegral `fmap` fdWriteBuf fd (castPtr p) (fromIntegral n)+ when (0 <= m && m <= n) $ writeBuf (p `plusPtr` m, n - m)+ writeBuf _ = return ()++ignoreUnsupportedOperation :: IO a -> IO ()+ignoreUnsupportedOperation act = void act `catchIOError` \ex ->+ if ioeGetErrorType ex == UnsupportedOperation+ then return ()+ else throwIO ex
+ RTS.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+module RTS ( RtsInfo(..), deployRts )++where++import Data.FileEmbed (embedFile)+import System.IO.Temp (createTempDirectory)+import System.FilePath ( (</>) )++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+++-- | A tarball with a relocatable package-db, containing the rts.+-- File "embedded-rts.tgz" is automatically created by the build system.+rts_tarball :: BS.ByteString+rts_tarball = $(embedFile "embedded-rts.tgz")++data RtsInfo = RtsInfo { rtsPackageDb :: FilePath, rtsPackage :: String }+++-- | Extracts the embedded rts-package to a temporary directory+-- inside the given directory, and returns its location.+deployRts :: FilePath -> IO RtsInfo+deployRts dir = do+ deployDir <- createTempDirectory dir "rts."++ extractTarball (LBS.fromStrict rts_tarball) deployDir++ return RtsInfo {+ rtsPackageDb = deployDir </> "embedded-rts" </> "pkgdb"+ , rtsPackage = "ide-backend-rts"+ }+ ++extractTarball :: LBS.ByteString -> FilePath -> IO ()+extractTarball tarball dest =+ Tar.unpack dest $ Tar.read $ GZip.decompress $ tarball
Run.hs view
@@ -11,7 +11,7 @@ -- any modules from the ghc package and the modules should not be reexported -- anywhere else, with the exception of @IdeSession.GHC.Server@. module Run- ( -- * Re-expored GHC API+ ( -- * Re-exported GHC API Ghc , runFromGhc , liftIO@@ -73,7 +73,7 @@ import DynFlags (defaultDynFlags) import Exception (ghandle) import ErrUtils (ErrMsg)-import FastString ( unpackFS )+import FastString (unpackFS, mkFastString) import GHC hiding ( ModuleName , RunResult(..)@@ -85,6 +85,7 @@ import Outputable (PprStyle, mkUserStyle) import RdrName (GlobalRdrEnv, GlobalRdrElt, gre_name) import RnNames (rnImports)+import SrcLoc (mkRealSrcSpan, mkRealSrcLoc) import TcRnMonad (initTc) import TcRnTypes (RnM) import RtClosureInspect (Term)@@ -155,7 +156,7 @@ -- | Compile a set of targets -- -- Returns the errors, loaded modules, and mapping from filenames to modules-compileInGhc :: FilePath -- ^ target directory+compileInGhc :: FilePath -- ^ target directory, only used for 'TargetsExclude' -> Bool -- ^ should we generate code -> Targets -- ^ targets -> StrictIORef (Strict [] SourceError) -- ^ the IORef where GHC stores errors@@ -317,14 +318,23 @@ return IdInfo{..} autoEnvs :: ModSummary -> IO [GlobalRdrElt]- autoEnvs ModSummary{ ms_mod+ autoEnvs ms@ModSummary{ ms_mod , ms_hsc_src , ms_srcimps , ms_textual_imps } = do let go :: RnM (a, GlobalRdrEnv, b, c) -> IO [GlobalRdrElt] go op = do+#if GHC_AFTER_710_1+ -- Not sure if this is the same thing that GHC would+ -- pass in, but this is just to initialize the state,+ -- and will be overridden before any uses.+ let srcSpan = mkRealSrcSpan loc loc+ loc = mkRealSrcLoc (mkFastString (HscTypes.msHsFilePath ms)) 1 1+ ((_warns, _errs), res) <- initTc session ms_hsc_src False ms_mod srcSpan op+#else ((_warns, _errs), res) <- initTc session ms_hsc_src False ms_mod op+#endif case res of Nothing -> do -- TODO: deal with import errors@@ -465,7 +475,7 @@ setPrintContext pprStyle localVars <- mkTerms >>= mapM (exportVar pprStyle)- ProperSpan srcSpan' <- liftIO $ extractSourceSpan srcSpan+ ProperSpan srcSpan' <- liftIO $ extractEitherSpan srcSpan prettyResTy <- prettyM pprStyle breakInfo_resty return BreakInfo {@@ -534,7 +544,7 @@ SevFatal -> Just KindError _ -> Nothing = do let msgstr = showSDocForUser flags (queryQual style) msg- sp <- extractSourceSpan srcspan+ sp <- extractEitherSpan srcspan modifyIORef errsRef (StrictList.cons $ SourceError errKind sp (Text.pack msgstr)) collectSrcError' _errsRef handlerOutput _ flags SevOutput _srcspan style msg@@ -563,7 +573,7 @@ case sourceErrorSpan e of Just real -> do- xSpan <- extractSourceSpan real+ xSpan <- extractEitherSpan real return $ SourceError KindError xSpan err Nothing -> return $ SourceError KindError (TextSpan noloc) err
Server.hs view
@@ -5,28 +5,32 @@ import Prelude hiding (mod, span) import Control.Concurrent (ThreadId, throwTo, forkIO, myThreadId, threadDelay)-import Control.Concurrent.Async (async)+import Control.Concurrent.Async (async, withAsync) import Control.Concurrent.MVar (MVar, newEmptyMVar)-import Control.Monad (void, unless, when)+import Control.Monad (void, unless, when, forever) import Control.Monad.State (StateT, runStateT) import Control.Monad.Trans.Class (lift) import Data.Accessor (accessor, (.>)) import Data.Accessor.Monad.MTL.State (set)-import Data.Function (on)-import Foreign.Ptr (Ptr, nullPtr)+import Data.Function (on, fix) import Foreign.C.Types (CFile)-import System.Environment (withArgs, getEnvironment)+import Foreign.Ptr (Ptr, nullPtr)+import GHC.IO.Exception (IOException(..), IOErrorType(..))+import System.Environment (withArgs, getEnvironment, setEnv) import System.FilePath ((</>)) import System.IO (Handle, hFlush, hClose)-import System.IO.Temp (createTempDirectory, openTempFile)+import System.IO.Temp (createTempDirectory, openTempFile, withSystemTempDirectory) import System.Mem (performGC)-import System.Posix (Fd)+import System.Posix (Fd, createSession) import System.Posix.IO import System.Posix.Files (createNamedPipe) import System.Posix.Process (forkProcess, getProcessStatus)+import System.Posix.Terminal (openPseudoTerminal)+import System.Posix.Signals (signalProcess, sigKILL, sigTERM)+import qualified Posix import System.Posix.Types (ProcessID) import qualified Control.Exception as Ex-import qualified Data.ByteString as BSS (hGetSome, hPut, null)+import qualified Data.ByteString as BSS import qualified Data.List as List import qualified Data.Text as Text import qualified System.Directory as Dir@@ -53,6 +57,7 @@ import HsWalk import Debug import GhcShim+import RTS foreign import ccall "fflush" fflush :: Ptr CFile -> IO () @@ -62,18 +67,23 @@ -- | Start the RPC server. Used from within the server executable. ghcServer :: [String] -> IO ()-ghcServer = rpcServer ghcServerEngine+ghcServer args =+ withSystemTempDirectory "ghc-server." $ \tmpDir -> do+ -- Prepare the rts support module+ rtsInfo <- deployRts tmpDir + -- Launch the server+ rpcServer (ghcServerEngine rtsInfo) args++ -- | The GHC server engine proper. -- -- This function runs in end endless loop inside the @Ghc@ monad, making -- incremental compilation possible.-ghcServerEngine :: FilePath -> RpcConversation -> IO ()-ghcServerEngine errorLog conv@RpcConversation{..} = do+ghcServerEngine :: RtsInfo -> FilePath -> RpcConversation -> IO ()+ghcServerEngine rtsInfo errorLog conv@RpcConversation{..} = do -- The initial handshake with the client- (configGenerateModInfo, initOpts, sessionDir) <- handleInit conv- let distDir = ideSessionDistDir sessionDir- sourceDir = ideSessionSourceDir sessionDir+ (configGenerateModInfo, initOpts, sourceDir, sessionDir, distDir) <- handleInit conv -- Submit static opts and get back leftover dynamic opts. dOpts <- submitStaticOpts initOpts@@ -90,7 +100,7 @@ -- Start handling requests. From this point on we don't leave the GHC monad. runFromGhc $ do -- Register startup options and perhaps our plugin in dynamic flags.- initSession distDir configGenerateModInfo dOpts errsRef stRef pluginRef progressCallback+ initSession distDir configGenerateModInfo dOpts rtsInfo errsRef stRef pluginRef progressCallback -- We store the DynFlags _after_ setting the "static" options, so that -- we restore to this state before every call to updateDynamicOpts@@ -115,11 +125,20 @@ conv pluginRef importsRef errsRef sourceDir genCode targets configGenerateModInfo return args- ReqRun runCmd -> do- (pid, stdin, stdout, errorLog') <- startConcurrentConversation sessionDir $ \_errorLog' conv' -> do- ghcWithArgs args $ ghcHandleRun conv' runCmd- liftIO $ put (pid, stdin, stdout, errorLog')- return args+ ReqRun runCmd+ | runCmdPty runCmd -> do+ fds <- liftIO openPseudoTerminal+ conversationTuple <- startConcurrentConversation sessionDir $ \_ _ _ ->+ ghcWithArgs args $ ghcHandleRunPtySlave fds runCmd+ liftIO $ runPtyMaster fds conversationTuple+ liftIO $ put conversationTuple+ return args+ | otherwise -> do+ conversationTuple <- startConcurrentConversation sessionDir $+ ghcConcurrentConversation $ \_errorLog' conv' ->+ ghcWithArgs args $ ghcHandleRun conv' runCmd+ liftIO $ put conversationTuple+ return args ReqSetEnv env -> do ghcHandleSetEnv conv initEnv env return args@@ -174,12 +193,13 @@ initSession :: FilePath -> Bool -> DynamicOpts+ -> RtsInfo -> StrictIORef (Strict [] SourceError) -> StrictIORef ExtractIdsSuspendedState -> StrictIORef (Strict (Map ModuleName) PluginResult) -> (String -> IO ()) -> Ghc ()-initSession distDir modInfo dOpts errsRef stRef pluginRef callback = do+initSession distDir modInfo dOpts rtsInfo errsRef stRef pluginRef callback = do flags <- getSessionDynFlags (flags', _, _) <- parseDynamicFlags flags $ dOpts ++ dynOpts @@ -191,8 +211,8 @@ where dynOpts :: DynamicOpts dynOpts = optsToDynFlags [- -- Just in case the user specified -hide-all-packages.- "-package ide-backend-rts"+ "-package-db " ++ rtsPackageDb rtsInfo+ , "-package " ++ rtsPackage rtsInfo -- Include cabal_macros.h , "-optP-include"@@ -217,8 +237,11 @@ #endif } -startConcurrentConversation :: FilePath -> (FilePath -> RpcConversation -> Ghc ()) -> Ghc (ProcessID, FilePath, FilePath, FilePath)-startConcurrentConversation sessionDir server = do+startConcurrentConversation+ :: FilePath+ -> (FilePath -> FilePath -> FilePath -> Ghc ())+ -> Ghc (ProcessID, FilePath, FilePath, FilePath)+startConcurrentConversation sessionDir inner = do -- Ideally, we'd have the child process create the temp directory and -- communicate the name back to us, so that the child process can remove the -- directories again when it's done with it. However, this means we need some@@ -244,11 +267,14 @@ -- because we need to change global state in the child process; in particular, -- we need to redirect stdin, stdout, and stderr (as well as some other global -- state, including withArgs).- liftIO $ performGC- processId <- forkGhcProcess $ ghcConcurrentConversation stdin stdout errorLog server+ liftIO performGC+ processId <- forkGhcProcess $ inner stdin stdout errorLog -- We wait for the process to finish in a separate thread so that we do not -- accumulate zombies+ --+ -- FIXME(mgs): I didn't write this, and I'm not sure I see the point+ -- of doing this. liftIO $ void $ forkIO $ void $ getProcessStatus True False processId @@ -269,7 +295,7 @@ } -- | Client handshake-handleInit :: RpcConversation -> IO (Bool, [String], FilePath)+handleInit :: RpcConversation -> IO (Bool, [String], FilePath, FilePath, FilePath) handleInit RpcConversation{..} = do GhcInitRequest{..} <- get @@ -289,7 +315,9 @@ return ( ghcInitGenerateModInfo , ghcInitOpts ++ packageDBFlags ghcInitUserPackageDB ghcInitSpecificPackageDBs+ , ghcInitSourceDir , ghcInitSessionDir+ , ghcInitDistDir ) -- | Handle a compile or type check request@@ -516,6 +544,65 @@ mapM_ ObjLink.unloadObj objects put () +runPtyMaster :: (Fd, Fd) -> (ProcessID, FilePath, FilePath, FilePath) -> IO ()+runPtyMaster (masterFd, slaveFd) (processId, stdin, stdout, errorLog) = do+ -- Since we're in the master process, close the slave FD.+ closeFd slaveFd+ let readOutput :: RpcConversation -> IO RunResult+ readOutput conv = fix $ \loop -> do+ bs <- Posix.readChunk masterFd `Ex.catch` \ex ->+ -- Ignore HardwareFaults as they seem to always happen when+ -- process exits..+ if ioe_type ex == HardwareFault+ then return BSS.empty+ else Ex.throwIO ex+ if BSS.null bs+ then return RunOk+ else do+ put conv (GhcRunOutp bs)+ loop+ handleRequests :: RpcConversation -> IO ()+ handleRequests conv = forever $ do+ request <- get conv+ case request of+ GhcRunInput bs -> Posix.write masterFd bs+ -- Fork a new thread because this could throw exceptions.+ GhcRunInterrupt -> void $ forkIO $ signalProcess sigTERM processId+ -- Turn a GHC exception into a RunResult+ ghcException :: GhcException -> IO RunResult+ ghcException = return . RunGhcException . show+ void $ forkIO $+ concurrentConversation stdin stdout errorLog $ \_ conv -> do+ result <- Ex.handle ghcException $+ withAsync (handleRequests conv) $ \_ ->+ readOutput conv+ put conv (GhcRunDone result)++ghcHandleRunPtySlave :: (Fd, Fd) -> RunCmd -> Ghc ()+ghcHandleRunPtySlave (masterFd, slaveFd) runCmd = do+ liftIO $ do+ -- Since we're in the slave process, close the master FD.+ closeFd masterFd+ -- Create a new session with a controlling terminal.+ void createSession+ Posix.setControllingTerminal slaveFd+ -- Redirect standard IO to the terminal FD.+ void $ dupTo slaveFd stdInput+ void $ dupTo slaveFd stdOutput+ void $ dupTo slaveFd stdError+ closeFd slaveFd+ -- Set TERM env variable+ setEnv "TERM" "xterm-256color"+ --FIXME: Properly pass the run result to the client as a GhcRunDone+ --value. Instead, we write it to standard output, which gets sent to+ --the terminal.+ result <- runInGhc runCmd+ case result of+ -- A successful result will be sent by runPtyMaster - only send+ -- failures.+ RunOk -> return ()+ _ -> liftIO $ putStrLn $ "\r\nProcess done: " ++ show result ++ "\r\n"+ -- | Handle a run request ghcHandleRun :: RpcConversation -> RunCmd -> Ghc () ghcHandleRun RpcConversation{..} runCmd = do@@ -706,10 +793,10 @@ forkGhcProcess = unsafeLiftIO forkProcess -- | Lifted version of concurrentConversation-ghcConcurrentConversation :: FilePath+ghcConcurrentConversation :: (FilePath -> RpcConversation -> Ghc ()) -> FilePath -> FilePath- -> (FilePath -> RpcConversation -> Ghc ())+ -> FilePath -> Ghc ()-ghcConcurrentConversation requestR responseW errorLog =- unsafeLiftIO2 (concurrentConversation requestR responseW errorLog)+ghcConcurrentConversation f requestR responseW errorLog =+ unsafeLiftIO2 (concurrentConversation requestR responseW errorLog) f
Setup.hs view
@@ -1,2 +1,195 @@ import Distribution.Simple-main = defaultMain+import Distribution.Simple.LocalBuildInfo ( withPrograms, compiler )+import Distribution.Simple.Program ( runProgram, lookupProgram, ghcPkgProgram )+import Distribution.Simple.Setup ( fromFlag, configVerbosity, buildVerbosity )+import Distribution.Simple.Utils ( notice, die )++import Control.Exception ( bracket )+import Control.Monad ( join, when, forM_, liftM2 )+import Data.Bits ( xor )+import Data.Word ( Word )+import System.Directory ( getCurrentDirectory, setCurrentDirectory+ , removeDirectoryRecursive, removeFile+ , doesDirectoryExist, doesFileExist+ , getDirectoryContents )+import System.Environment ( getArgs )+import System.FilePath ( (</>), takeExtension )++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as List+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+++main :: IO ()+main = join $ liftM2 mainWith getArgs getCurrentDirectory++mainWith :: [String] -> FilePath -> IO ()+mainWith cmdLineArgs cwd = defaultMainWithHooksArgs hooks cmdLineArgs+ where+ hooks = simpleUserHooks {++ postConf = \args flags pd lbi ->+ do configureRts lbi flags+ (postConf simpleUserHooks) args flags pd lbi++ , buildHook = \pd lbi hs flags ->+ do buildRts lbi flags+ makeRtsRelocatable lbi flags+ makeTarball "embedded-rts.tgz" cwd [dirToEmbed]+ (buildHook simpleUserHooks) pd lbi hs flags++ , preClean = \args flags ->+ do onRtsDir $ runSetupClean+ (preClean simpleUserHooks) args flags+ }+++ dirToEmbed = "embedded-rts"+ pkgDbPath = dirToEmbed </> "pkgdb"++ onRtsDir = withCurrentDirectory "ide-backend-rts"++ rawRunSetup args lbi verbosity = do+ let args' = args ++ [rtsBuildDirArg lbi]+ notice verbosity $ "Running cabal with " ++ show args'+ defaultMainArgs args'+ runSetup cmd lbi verbosity = rawRunSetup [cmd] lbi verbosity+ rerunSetupWith flags lbi verbosity = rawRunSetup (cmdLineArgs ++ flags) lbi verbosity+ -- NB. we must set builddir explicitly (and as the final arg)+ -- since when rerunning the command during configuration, the default+ -- builddir may be changed by a flag (e.g. as "stack" does), and if we+ -- are not aware of the right builddir on the subsequent calls, we won't+ -- find the configuration info and fail.++ rtsBuildDirArg lbi = "--builddir=dist/buildinfo-" ++ show (hashString $ show (compiler lbi))+ -- NB. We make the builddir a function of the compiler being used+ -- (approximated by the local build info). This is only relevant for+ -- people hacking on this library: we are trying to avoid the scenario+ -- where one first builds the server using compiler A and then, on the same+ -- directory, rebuilds the server using compiler B, but the "Setup build" step+ -- on the rts directory finds that the rts is already built (but with compiler A!),+ -- leaves it as is, and one ends up with a server for B with an embedded rts for A.+ -- Using a different builddir for A and B, this won't happen.+ -- Note also that we put all the local build dirs under the same root dist, so we+ -- know what to remove during cleanup++ runSetupClean = defaultMainArgs ["clean", "--builddir=dist"]+++ -- Run "Setup configure" on the directory of the rts.+ -- We ensure that we pass exactly the same command line arguments+ -- we received (since those can be indicating the version of ghc+ -- with which we are compiling the server) but override the location+ -- of the output, since we want the package-db on "embedded-rts"+ configureRts lbi flags = do+ let verbosity = fromFlag (configVerbosity flags)+ notice verbosity "configuring rts..."++ let dirToEmbedFullPath = cwd </> dirToEmbed+ pkgDbFullPath = cwd </> pkgDbPath++ outOfTheWay dirToEmbed+ runGhcPkg ["init", pkgDbPath] lbi verbosity++ onRtsDir $+ rerunSetupWith [+ "--package-db=" ++ pkgDbFullPath+ , "--libdir=" ++ (dirToEmbedFullPath </> "lib")+ , "--bindir=" ++ (dirToEmbedFullPath </> "bin")+ , "--datadir=" ++ (dirToEmbedFullPath </> "share")+ , "--docdir=" ++ (dirToEmbedFullPath </> "doc")+ , "--htmldir=" ++ (dirToEmbedFullPath </> "doc")+ , "--haddockdir=" ++ (dirToEmbedFullPath </> "doc")+ , "--enable-library-for-ghci"+ ] lbi verbosity+++ -- Builds the rts, which will end up in embedded-rts, and+ -- registers it to a package-db contained there as well+ buildRts lbi flags = do+ let verbosity = fromFlag (buildVerbosity flags)+ notice verbosity "building rts..."++ onRtsDir $ do+ runSetup "build" lbi verbosity++ notice verbosity "locally registering rts..."+ onRtsDir $ do+ runSetup "copy" lbi verbosity+ runSetup "register" lbi verbosity++ -- This hack is a workaround to Cabal not having yet (as of 1.22)+ -- a clear story regarding relocatable packages. We just replace+ -- every occurrence of 'cwd </> dirToEmbed' by the string "${pkgroot}"+ -- everywhere in the installed-package-conf and run 'ghc-pkg recache'+ -- afterwards.+ makeRtsRelocatable lbi flags = do+ let verbosity = fromFlag (buildVerbosity flags)+ notice verbosity "making rts a relocatable package..."++ pkgDb_files <- getDirectoryContents pkgDbPath+ let conf_files = filter ((== ".conf").takeExtension) pkgDb_files++ -- we expect only one conf file, if we couldn't find it the hack+ -- has failed (better to detect here than at runtime!)+ when (null conf_files) $+ die "Couldn't file a conf file to hack"++ forM_ (map (pkgDbPath </>) conf_files) $ \conf_file -> do++ -- NB. ghc-pkg expects conf files to be in utf-8+ contents <- T.decodeUtf8 `fmap` BS.readFile conf_file++ -- we do a simple text substitution instead of parsing the conf file+ -- using Distribution.InstalledPackageInfo; the text substitution is+ -- safe enough and arguably more future-proof.+ let hack = T.replace (T.pack $ cwd </> dirToEmbed) (T.pack "${pkgroot}")+ new_contents = hack contents++ -- make sure that we have indeed made a substitution, otherwise this+ -- will blow at runtime....+ when (contents == new_contents) $+ die "No substitution, hack failed"++ BS.writeFile conf_file $ T.encodeUtf8 (new_contents)++ -- Update the package cache+ runGhcPkg ["recache", "--package-db=" ++ pkgDbPath] lbi verbosity++ runGhcPkg args lbi verb =+ let Just ghc_pkg = lookupProgram ghcPkgProgram (withPrograms lbi)+ in runProgram verb ghc_pkg args+++-- Available in directory-1.2.3.0+withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory dir action =+ bracket getCurrentDirectory setCurrentDirectory $ \_ -> do+ setCurrentDirectory dir+ action++-- Removes the given file or directory+outOfTheWay :: FilePath -> IO ()+outOfTheWay fileOrDir = do+ is_dir <- doesDirectoryExist fileOrDir+ if is_dir+ then removeDirectoryRecursive fileOrDir+ else do is_file <- doesFileExist fileOrDir+ when is_file $+ removeFile fileOrDir++makeTarball :: FilePath -> FilePath -> [FilePath] -> IO ()+makeTarball tarball base contents =+ LBS.writeFile tarball . GZip.compress . Tar.write =<< Tar.pack base contents+++-- Based on the Hashable String instance+hashString :: String -> Word+hashString = List.foldl' (\salt x -> salt `combine` hashChar x) 0x087fc72c+ where+ hashChar = fromIntegral . fromEnum+ combine h1 h2 = (h1 * 16777619) `xor` h2
+ ide-backend-rts/IdeBackendRTS.hs view
@@ -0,0 +1,126 @@+module IdeBackendRTS (+ run+ , RunBufferMode(..)+ , Maybe(..)+ ) where++import Control.Concurrent (forkIO, threadDelay, killThread)+import Control.Concurrent.MVar (MVar, takeMVar, putMVar)+import qualified System.IO as IO+import qualified Control.Exception as Ex+import Control.Monad (forever)++import GHC.IO.Handle.Types (+ Handle(FileHandle)+ , HandleType(ClosedHandle, ReadHandle, WriteHandle)+ , nativeNewlineMode+ , Handle__+ , haType+ )+import GHC.IO.Handle.Internals (+ mkHandle+ , closeTextCodecs+ , ioe_finalizedHandle+ , flushWriteBuffer+ )+import qualified GHC.IO.FD as FD++run :: RunBufferMode -> RunBufferMode -> IO a -> IO ()+run outBMode errBMode io = do+ let resetHandles = do+ resetStdin IO.utf8+ resetStdout IO.utf8+ resetStderr IO.utf8+ let io' = do _result <- io ; return () -- Throw away any snippet result+ withBuffering IO.stdout outBMode (withBuffering IO.stderr errBMode io')+ `Ex.finally` resetHandles++{-------------------------------------------------------------------------------+ Buffer modes+-------------------------------------------------------------------------------}++data RunBufferMode =+ RunNoBuffering+ | RunLineBuffering (Maybe Int)+ | RunBlockBuffering (Maybe Int) (Maybe Int)+ deriving Read++withBuffering :: IO.Handle -> RunBufferMode -> IO a -> IO a+withBuffering h mode io = do+ IO.hSetBuffering h (bufferMode mode)+ result <- withBufferTimeout h (bufferTimeout mode) io+ ignoreIOExceptions $ IO.hFlush h+ return result++ignoreIOExceptions :: IO () -> IO ()+ignoreIOExceptions = let handler :: Ex.IOException -> IO ()+ handler _ = return ()+ in Ex.handle handler++bufferMode :: RunBufferMode -> IO.BufferMode+bufferMode RunNoBuffering = IO.NoBuffering+bufferMode (RunLineBuffering _) = IO.LineBuffering+bufferMode (RunBlockBuffering sz _) = IO.BlockBuffering sz++bufferTimeout :: RunBufferMode -> Maybe Int+bufferTimeout RunNoBuffering = Nothing+bufferTimeout (RunLineBuffering t) = t+bufferTimeout (RunBlockBuffering _ t) = t++withBufferTimeout :: IO.Handle -> Maybe Int -> IO a -> IO a+withBufferTimeout _ Nothing io = io+withBufferTimeout h (Just n) io = do+ tid <- forkIO . ignoreIOExceptions . forever $ threadDelay n >> IO.hFlush h+ result <- io+ killThread tid+ return result++swapFileHandles :: Handle -> Handle -> IO ()+swapFileHandles (FileHandle _ h1) (FileHandle _ h2) = Ex.mask_ $ do+ h1' <- takeMVar h1+ h2' <- takeMVar h2+ putMVar h1 h2'+ putMVar h2 h1'+swapFileHandles _ _ =+ Ex.throwIO (userError "swapFileHandles: unsupported handles")++{-------------------------------------------------------------------------------+ To reset the handle we duplicate the implementation of 'stdin', 'stdout' or+ 'stderr' and then use 'swapFileHandles' to swap the MVar contents of the real+ Handle+-------------------------------------------------------------------------------}++resetStdin :: IO.TextEncoding -> IO ()+resetStdin enc = do+ new <- mkHandle FD.stdin "<stdin>" ReadHandle True (Just enc)+ nativeNewlineMode{-translate newlines-}+ (Just stdHandleFinalizer) Nothing+ swapFileHandles new IO.stdin++resetStdout :: IO.TextEncoding -> IO ()+resetStdout enc = do+ new <- mkHandle FD.stdout "<stdout>" WriteHandle True (Just enc)+ nativeNewlineMode{-translate newlines-}+ (Just stdHandleFinalizer) Nothing+ swapFileHandles new IO.stdout++resetStderr :: IO.TextEncoding -> IO ()+resetStderr enc = do+ new <- mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-}+ (Just enc)+ nativeNewlineMode{-translate newlines-}+ (Just stdHandleFinalizer) Nothing+ swapFileHandles new IO.stderr++{-------------------------------------------------------------------------------+ Taken directly from the GHC.IO.Handle.FD (not exported)+-------------------------------------------------------------------------------}++stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()+stdHandleFinalizer fp m = do+ h_ <- takeMVar m+ flushWriteBuffer h_+ case haType h_ of+ ClosedHandle -> return ()+ _other -> closeTextCodecs h_+ putMVar m (ioe_finalizedHandle fp)
+ ide-backend-rts/LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2015 FP Complete++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ ide-backend-rts/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ide-backend-rts/ide-backend-rts.cabal view
@@ -0,0 +1,21 @@+-- Initial ide-backend-rts.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: ide-backend-rts+version: 0.1.3.1+synopsis: RTS for the IDE backend+description: Add on package used internally. End users should not need to use this.+license: MIT+license-file: LICENSE+author: Duncan Coutts, Mikolaj Konarski, Edsko de Vries+maintainer: Duncan Coutts <duncan@well-typed.com>+copyright: (c) 2015 FP Complete+category: Development+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: IdeBackendRTS + -- other-modules: + build-depends: base >=4.5 && <5+ ghc-options: -Wall
ide-backend-server.cabal view
@@ -1,5 +1,5 @@ name: ide-backend-server-version: 0.9.0+version: 0.10.0 synopsis: An IDE backend server description: Server executable used internally by the ide-backend library. license: MIT@@ -8,9 +8,18 @@ maintainer: Duncan Coutts <duncan@well-typed.com> copyright: (c) 2015 FP Complete category: Development-build-type: Simple+build-type: Custom cabal-version: >=1.10+extra-tmp-files: embedded-rts, embedded-rts.tgz+ -- This directory will be created by the custom setup+ -- and should be removed on clean up. +extra-source-files: ide-backend-rts/ide-backend-rts.cabal,+ ide-backend-rts/LICENSE,+ ide-backend-rts/Setup.hs,+ ide-backend-rts/IdeBackendRTS.hs++ executable ide-backend-server main-is: ide-backend-server.hs other-modules: IdPropCaching@@ -28,8 +37,10 @@ GhcShim.GhcShim78 GhcShim.GhcShim710 GhcShim+ Posix+ RTS build-depends: base < 10,- ghc == 7.4.* || == 7.8.* || == 7.10.*,+ ghc == 7.4.* || == 7.8.* || == 7.10.* || == 7.11.*, containers >= 0.4.1 && < 1, bytestring >= 0.9.2 && < 1, data-accessor >= 0.2 && < 0.3,@@ -47,7 +58,10 @@ filemanip >= 0.3.6.2 && < 0.4, array >= 0.4 && < 0.6, temporary >= 1.1.2.4 && < 1.3,- ide-backend-common >= 0.9 && < 0.10+ tar >= 0.3 && < 0.5,+ zlib >= 0.5.3 && < 0.7,+ file-embed >= 0.0 && < 0.1,+ ide-backend-common >= 0.10 && < 0.11 -- The standard macros don't give us 7.6.x granularity -- We _could_ add support for 7.6, 7.6.1 specifically is broken (#7548)@@ -67,7 +81,7 @@ Cabal cpp-options: -DGHC_78 ghc-options: -dynamic- if impl(ghc == 7.10.*)+ if impl(ghc == 7.10.*) || impl(ghc == 7.11.*) build-depends: time == 1.5.*, haddock-api == 2.16.*, -- although from 7.10 basic datatypes are defined in@@ -76,6 +90,8 @@ Cabal cpp-options: -DGHC_710 ghc-options: -dynamic+ if impl(ghc > 7.10.1)+ cpp-options: -DGHC_AFTER_710_1 default-language: Haskell2010 default-extensions: MonoLocalBinds,