diff --git a/IdeSession/GHC/API.hs b/IdeSession/GHC/API.hs deleted file mode 100644 --- a/IdeSession/GHC/API.hs +++ /dev/null @@ -1,90 +0,0 @@ --- | Types for the messages to and fro the GHC server --- --- It is important that none of the types here rely on the GHC library. -{-# LANGUAGE DeriveDataTypeable #-} -module IdeSession.GHC.API ( - -- * Requests - module IdeSession.GHC.Requests - -- * Responses - , module IdeSession.GHC.Responses - -- * Configuration - , ideBackendApiVersion - , hsExtensions - , hsBootExtensions - , cExtensions - , cHeaderExtensions - , sourceExtensions - , cabalMacrosLocation - -- * Paths - , ideSessionSourceDir - , ideSessionDataDir - , ideSessionDistDir - , ideSessionObjDir - ) where - -import System.FilePath (()) - -import IdeSession.GHC.Requests -import IdeSession.GHC.Responses - --- | For detecting runtime version mismatch between the server and the library --- --- We use a Unix timestamp for this so that these API versions have some --- semantics (http://www.epochconverter.com/, GMT). -ideBackendApiVersion :: Int -ideBackendApiVersion = 1426765899 - -{------------------------------------------------------------------------------ - Configuration -------------------------------------------------------------------------------} - --- | Haskell source files -hsExtensions :: [FilePath] -hsExtensions = [".hs", ".lhs"] - --- | Haskell @.boot@ files -hsBootExtensions :: [FilePath] -hsBootExtensions = [".hs-boot", ".lhs-boot"] - --- | C source files -cExtensions :: [FilePath] -cExtensions = [".c"] - --- | C header files -cHeaderExtensions :: [FilePath] -cHeaderExtensions = [".h"] - --- | Extensions of all source files we keep in our source directory. -sourceExtensions :: [FilePath] -sourceExtensions = hsExtensions - ++ hsBootExtensions - ++ cExtensions - ++ cHeaderExtensions - --- TODO: perhaps create dist/build/autogen and put macros there so that --- Cabal.autogenModulesDir can use it for compilation of C files? -cabalMacrosLocation :: FilePath -> FilePath -cabalMacrosLocation ideDistDir = ideDistDir "cabal_macros.h" - -{------------------------------------------------------------------------------- - Paths - - These are all meant to be relative to the session dir --------------------------------------------------------------------------------} - --- | The directory to use for managing source files. -ideSessionSourceDir :: FilePath -> FilePath -ideSessionSourceDir sessionDir = sessionDir "src" - --- | The directory to use for data files that may be accessed by the --- running program. The running program will have this as its CWD. -ideSessionDataDir :: FilePath -> FilePath -ideSessionDataDir sessionDir = sessionDir "data" - --- | Cabal "dist" prefix. -ideSessionDistDir :: FilePath -> FilePath -ideSessionDistDir sessionDir = sessionDir "dist" - --- | Directory where we store compiled C files (objects) -ideSessionObjDir :: FilePath -> FilePath -ideSessionObjDir sessionDir = sessionDir "ffi" diff --git a/IdeSession/GHC/Requests.hs b/IdeSession/GHC/Requests.hs deleted file mode 100644 --- a/IdeSession/GHC/Requests.hs +++ /dev/null @@ -1,192 +0,0 @@ --- | GHC requests --- --- GHC requests use "IdeSession.Types.Public" types. -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -module IdeSession.GHC.Requests ( - GhcInitRequest(..) - , GhcRequest(..) - , GhcRunRequest(..) - , RunCmd(..) - ) where - -import Data.Binary -import Data.ByteString (ByteString) -import Data.Typeable (Typeable) -import Control.Applicative ((<$>), (<*>)) - -import Text.Show.Pretty (PrettyVal(..)) -import GHC.Generics - -import IdeSession.Types.Public - --- | Initial handshake with the ghc server --- --- Ideally we'd send over the entire IdeStaticInfo but this includes some --- Cabal fields, and the ghc server does -not- compile against Cabal --- (although this isn't so important anymore now that we use Cabal-ide-backend) -data GhcInitRequest = GhcInitRequest { - ghcInitClientApiVersion :: Int - , ghcInitGenerateModInfo :: Bool - , ghcInitOpts :: [String] - , ghcInitUserPackageDB :: Bool - , ghcInitSpecificPackageDBs :: [String] - , ghcInitSessionDir :: FilePath - } - deriving (Typeable, Generic) - -data GhcRequest - = ReqCompile { - reqCompileGenCode :: Bool - , reqCompileTargets :: Targets - } - | ReqRun { - reqRunCmd :: RunCmd - } - | ReqSetEnv { - reqSetEnv :: [(String, Maybe String)] - } - | ReqSetArgs { - reqSetArgs :: [String] - } - | ReqBreakpoint { - reqBreakpointModule :: ModuleName - , reqBreakpointSpan :: SourceSpan - , reqBreakpointValue :: Bool - } - | ReqPrint { - reqPrintVars :: Name - , reqPrintBind :: Bool - , reqPrintForce :: Bool - } - | ReqLoad { - reqLoad :: [FilePath] - } - | ReqUnload { - reqUnload :: [FilePath] - } - | ReqSetGhcOpts { - reqSetGhcOpts :: [String] - } - -- | For debugging only! :) - | ReqCrash { - reqCrashDelay :: Maybe Int - } - deriving (Typeable, Generic, Show) - -data RunCmd = - RunStmt { - runCmdModule :: String - , runCmdFunction :: String - , runCmdStdout :: RunBufferMode - , runCmdStderr :: RunBufferMode - } - | Resume - deriving (Typeable, Generic, Show) - -instance PrettyVal GhcInitRequest -instance PrettyVal GhcRequest -instance PrettyVal RunCmd - -data GhcRunRequest = - GhcRunInput ByteString - | GhcRunInterrupt - deriving Typeable - -instance Binary GhcInitRequest where - put (GhcInitRequest{..}) = do - -- Note: we intentionally write the API version first. This makes it - -- possible (in theory at least) to have some form of backwards API - -- compatibility. - put ghcInitClientApiVersion - put ghcInitGenerateModInfo - put ghcInitOpts - put ghcInitUserPackageDB - put ghcInitSpecificPackageDBs - put ghcInitSessionDir - - get = GhcInitRequest <$> get - <*> get - <*> get - <*> get - <*> get - <*> get - -instance Binary GhcRequest where - put ReqCompile{..} = do - putWord8 0 - put reqCompileGenCode - put reqCompileTargets - put ReqRun{..} = do - putWord8 1 - put reqRunCmd - put ReqSetEnv{..} = do - putWord8 2 - put reqSetEnv - put ReqSetArgs{..} = do - putWord8 3 - put reqSetArgs - put ReqBreakpoint{..} = do - putWord8 4 - put reqBreakpointModule - put reqBreakpointSpan - put reqBreakpointValue - put ReqPrint{..} = do - putWord8 5 - put reqPrintVars - put reqPrintBind - put reqPrintForce - put ReqLoad{..} = do - putWord8 6 - put reqLoad - put ReqUnload{..} = do - putWord8 7 - put reqUnload - put ReqSetGhcOpts{..} = do - putWord8 8 - put reqSetGhcOpts - put ReqCrash{..} = do - putWord8 255 - put reqCrashDelay - - get = do - header <- getWord8 - case header of - 0 -> ReqCompile <$> get <*> get - 1 -> ReqRun <$> get - 2 -> ReqSetEnv <$> get - 3 -> ReqSetArgs <$> get - 4 -> ReqBreakpoint <$> get <*> get <*> get - 5 -> ReqPrint <$> get <*> get <*> get - 6 -> ReqLoad <$> get - 7 -> ReqUnload <$> get - 8 -> ReqSetGhcOpts <$> get - 255 -> ReqCrash <$> get - _ -> fail "GhcRequest.get: invalid header" - -instance Binary RunCmd where - put (RunStmt {..}) = do - putWord8 0 - put runCmdModule - put runCmdFunction - put runCmdStdout - put runCmdStderr - put Resume = do - putWord8 1 - - get = do - header <- getWord8 - case header of - 0 -> RunStmt <$> get <*> get <*> get <*> get - 1 -> return Resume - _ -> fail "RunCmd.get: invalid header" - -instance Binary GhcRunRequest where - put (GhcRunInput bs) = putWord8 0 >> put bs - put GhcRunInterrupt = putWord8 1 - - get = do - header <- getWord8 - case header of - 0 -> GhcRunInput <$> get - 1 -> return GhcRunInterrupt - _ -> fail "GhcRunRequest.get: invalid header" diff --git a/IdeSession/GHC/Responses.hs b/IdeSession/GHC/Responses.hs deleted file mode 100644 --- a/IdeSession/GHC/Responses.hs +++ /dev/null @@ -1,127 +0,0 @@ --- | Responses from the GHC server --- --- The server responds with "IdeSession.Types.Private" types -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -module IdeSession.GHC.Responses ( - GhcInitResponse(..) - , GhcCompileResponse(..) - , GhcCompileResult(..) - , GhcRunResponse(..) - , GhcVersion(..) - ) where - -import Data.Binary -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Typeable (Typeable) -import Control.Applicative ((<$>), (<*>)) - -import IdeSession.Types.Private -import IdeSession.Types.Progress -import IdeSession.Strict.Container -import IdeSession.Util (Diff) - -import Text.Show.Pretty -import GHC.Generics - -data GhcInitResponse = GhcInitResponse { - ghcInitVersion :: GhcVersion - } - deriving (Typeable, Generic) - -data GhcCompileResponse = - GhcCompileProgress Progress - | GhcCompileDone GhcCompileResult - deriving (Typeable, Generic) - --- NOTE: These fields cannot be made strict (at least, not easily) -data GhcCompileResult = GhcCompileResult { - ghcCompileErrors :: Strict [] SourceError - , ghcCompileLoaded :: Strict [] ModuleName - , ghcCompileCache :: ExplicitSharingCache - -- Computed from the GhcSummary (independent of the plugin, and hence - -- available even when the plugin does not run) - , ghcCompileFileMap :: Strict (Map FilePath) ModuleId - , ghcCompileImports :: Strict (Map ModuleName) (Diff (Strict [] Import)) - , ghcCompileAuto :: Strict (Map ModuleName) (Diff (Strict [] IdInfo)) - -- Computed by the plugin - , ghcCompileSpanInfo :: Strict (Map ModuleName) (Diff IdList) - , ghcCompilePkgDeps :: Strict (Map ModuleName) (Diff (Strict [] PackageId)) - , ghcCompileExpTypes :: Strict (Map ModuleName) (Diff [(SourceSpan, Text)]) - , ghcCompileUseSites :: Strict (Map ModuleName) (Diff UseSites) - } - deriving (Typeable, Generic) - -data GhcRunResponse = - GhcRunOutp ByteString - | GhcRunDone RunResult - deriving (Typeable, Generic) - --- | GHC version --- --- NOTE: Defined in such a way that the Ord instance makes sense. -data GhcVersion = GHC_7_4 | GHC_7_8 | GHC_7_10 - deriving (Typeable, Show, Eq, Ord, Generic) - -instance PrettyVal GhcInitResponse -instance PrettyVal GhcCompileResponse -instance PrettyVal GhcCompileResult -instance PrettyVal GhcRunResponse -instance PrettyVal GhcVersion - -instance Binary GhcInitResponse where - put (GhcInitResponse{..}) = do - put ghcInitVersion - get = GhcInitResponse <$> get - -instance Binary GhcCompileResponse where - put (GhcCompileProgress progress) = putWord8 0 >> put progress - put (GhcCompileDone result) = putWord8 1 >> put result - - get = do - header <- getWord8 - case header of - 0 -> GhcCompileProgress <$> get - 1 -> GhcCompileDone <$> get - _ -> fail "GhcCompileRespone.get: invalid header" - -instance Binary GhcCompileResult where - put GhcCompileResult{..} = do - put ghcCompileErrors - put ghcCompileLoaded - put ghcCompileCache - put ghcCompileFileMap - put ghcCompileImports - put ghcCompileAuto - put ghcCompileSpanInfo - put ghcCompilePkgDeps - put ghcCompileExpTypes - put ghcCompileUseSites - - get = GhcCompileResult <$> get <*> get <*> get - <*> get <*> get <*> get - <*> get <*> get <*> get <*> get - -instance Binary GhcRunResponse where - put (GhcRunOutp bs) = putWord8 0 >> put bs - put (GhcRunDone r) = putWord8 1 >> put r - - get = do - header <- getWord8 - case header of - 0 -> GhcRunOutp <$> get - 1 -> GhcRunDone <$> get - _ -> fail "GhcRunResponse.get: invalid header" - -instance Binary GhcVersion where - put GHC_7_4 = putWord8 0 - put GHC_7_8 = putWord8 1 - put GHC_7_10 = putWord8 2 - - get = do - header <- getWord8 - case header of - 0 -> return GHC_7_4 - 1 -> return GHC_7_8 - 2 -> return GHC_7_10 - _ -> fail "GhcVersion.get: invalid header" diff --git a/IdeSession/RPC/API.hs b/IdeSession/RPC/API.hs deleted file mode 100644 --- a/IdeSession/RPC/API.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, RankNTypes #-} -module IdeSession.RPC.API ( - -- * External exceptions - ExternalException(..) - , serverKilledException - -- * Client-server communication - , RpcConversation(..) - , Request(..) - , Response(..) - -- * Lazy bytestring with incremental Binary instance - , IncBS(..) - -- * IO utils - , hPutFlush - , ignoreIOExceptions - , openPipeForWriting - , openPipeForReading - ) where - -import Prelude hiding (take) -import Control.Applicative ((<$>)) -import Control.Concurrent (threadDelay) -import Data.Binary (Binary) -import Data.Typeable (Typeable) -import System.IO (Handle, hFlush, openFile, IOMode(..), hPutChar, hGetChar) -import qualified Control.Exception as Ex -import qualified Data.Binary as Binary -import qualified Data.ByteString as BSS -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.ByteString.Lazy.Internal as BSL - --------------------------------------------------------------------------------- --- Exceptions thrown by the RPC server are retrown locally as -- --- 'ExternalException's -- --------------------------------------------------------------------------------- - --- | Exceptions thrown by the remote server -data ExternalException = ExternalException { - -- | The output from the server on stderr - externalStdErr :: String - -- | The local exception that was thrown and alerted us to the problem - , externalException :: Maybe Ex.IOException - } - deriving (Eq, Typeable) - -instance Show ExternalException where - show (ExternalException err Nothing) = - "External exception: " ++ err - show (ExternalException err (Just ex)) = - "External exception: " ++ err ++ ". Local exception: " ++ show ex - -instance Ex.Exception ExternalException - --- | Generic exception thrown if the server gets killed for unknown reason -serverKilledException :: Maybe Ex.IOException -> ExternalException -serverKilledException ex = ExternalException "Server killed" ex - -{------------------------------------------------------------------------------ - Client-server communication -------------------------------------------------------------------------------} - -data RpcConversation = RpcConversation { - get :: forall a. (Typeable a, Binary a) => IO a - , put :: forall a. (Typeable a, Binary a) => a -> IO () - } - -data Request = Request IncBS | RequestShutdown - deriving Show - -newtype Response = Response IncBS - -instance Binary Request where - put (Request bs) = Binary.putWord8 0 >> Binary.put bs - put RequestShutdown = Binary.putWord8 1 - - get = do - header <- Binary.getWord8 - case header of - 0 -> Request <$> Binary.get - 1 -> return RequestShutdown - _ -> fail "Request.get: invalid header" - -instance Binary Response where - put (Response bs) = Binary.put bs - get = Response <$> Binary.get - -{------------------------------------------------------------------------------ - Lazy bytestring with an incremental Binary instance - - Note only does this avoid loading the entire ByteString into memory when - serializing stuff, the standard Binary instance for Lazy bytestring is - actually broken in 0.5 (http://hpaste.org/87401; fixed in 0.7, but even there - still requires the length of the bytestring upfront). -------------------------------------------------------------------------------} - -newtype IncBS = IncBS { unIncBS :: BSL.ByteString } - -instance Binary IncBS where - put (IncBS BSL.Empty) = Binary.putWord8 0 - put (IncBS (BSL.Chunk b bs)) = do Binary.putWord8 1 - Binary.put b - Binary.put (IncBS bs) - - get = go [] - where - go :: [BSS.ByteString] -> Binary.Get IncBS - go acc = do - header <- Binary.getWord8 - case header of - 0 -> return . IncBS . BSL.fromChunks . reverse $ acc - 1 -> do b <- Binary.get ; go (b : acc) - _ -> fail "IncBS.get: invalid header" - -instance Show IncBS where - show = show . unIncBS - -{------------------------------------------------------------------------------ - Some IO utils -------------------------------------------------------------------------------} - --- | Write a bytestring to a buffer and flush -hPutFlush :: Handle -> BSL.ByteString -> IO () -hPutFlush h bs = BSL.hPut h bs >> ignoreIOExceptions (hFlush h) - --- | Ignore IO exceptions -ignoreIOExceptions :: IO () -> IO () -ignoreIOExceptions = Ex.handle ignore - where - ignore :: Ex.IOException -> IO () - ignore _ = return () - --- | Open a pipe for writing --- --- This is meant to be used together with 'openPipeForReading' -openPipeForWriting :: FilePath -> Int -> IO Handle -openPipeForWriting fp = go - where - go :: Int -> IO Handle - go timeout = do - -- We cannot open a pipe for writing without a corresponding reader - mh <- Ex.try $ openFile fp WriteMode - case mh of - Left ex -> - if timeout > delay - then do threadDelay delay - go (timeout - delay) - else Ex.throwIO (RPCPipeNotCreated ex) - Right h -> do - hPutChar h '!' - hFlush h - return h - - delay :: Int - delay = 10000 -- 10 ms - -data RPCPipeNotCreated = RPCPipeNotCreated Ex.IOException - deriving Typeable -instance Ex.Exception RPCPipeNotCreated -instance Show RPCPipeNotCreated where - show (RPCPipeNotCreated e) = "The bidirectional RPC pipe could not be opened. Exception was: " ++ show e - --- | Open a pipe for reading --- --- This is meant to be used together with 'openPipeForWriting' -openPipeForReading :: FilePath -> Int -> IO Handle -openPipeForReading fp = \timeout -> do - -- We _can_ open a pipe for reading without a corresponding writer - h <- openFile fp ReadMode - -- But if there is no corresponding writer, then trying to read from the - -- pipe will report EOF. So we wait. - go h timeout - return h - where - go :: Handle -> Int -> IO () - go h timeout = do - mc <- Ex.try $ hGetChar h - case mc of - Left ex -> - if timeout > delay - then do threadDelay delay - go h (timeout - delay) - else Ex.throwIO (RPCPipeNotCreated ex) - Right '!' -> - return () - Right c -> - Ex.throwIO (userError $ "openPipeForReading: Unexpected " ++ show c) - - delay :: Int - delay = 10000 -- 10 ms diff --git a/IdeSession/RPC/Server.hs b/IdeSession/RPC/Server.hs deleted file mode 100644 --- a/IdeSession/RPC/Server.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable, RankNTypes, GADTs #-} -{-# OPTIONS_GHC -Wall #-} -module IdeSession.RPC.Server - ( rpcServer - , concurrentConversation - , RpcConversation(..) - ) where - -import Prelude hiding (take) -import System.IO - ( Handle - , hSetBinaryMode - , hSetBuffering - , BufferMode(BlockBuffering) - ) -import System.Posix.Types (Fd) -import System.Posix.IO (closeFd, fdToHandle) -import Control.Monad (void) -import qualified Control.Exception as Ex -import Control.Concurrent (threadDelay) -import Control.Concurrent.Chan (Chan, newChan, writeChan) -import qualified Data.ByteString.Lazy.Char8 as BSL -import Control.Concurrent.Async (Async, async) -import Data.Binary (encode, decode) - -import IdeSession.Util.BlockingOps (readChan, wait, waitAny) -import IdeSession.RPC.API -import IdeSession.RPC.Stream - --------------------------------------------------------------------------------- --- Server-side API -- --------------------------------------------------------------------------------- - --- Start the RPC server. For an explanation of the command line arguments, see --- 'forkRpcServer'. This function does not return until the client requests --- termination of the RPC conversation (or there is an error). --- --- The server is passed the RpcConversation to communicate with the client, --- as well as the path to the exception log (rarely needed -- only needed --- if the server thread kills the whole process unconditionally, without --- throwing an exception). -rpcServer :: (FilePath -> RpcConversation -> IO ()) -- ^ Request server - -> [String] -- ^ Command line args - -> IO () -rpcServer handler args = do - let readFd :: String -> Fd - readFd fd = fromIntegral (read fd :: Int) - - let errorLog : fds = args - [requestR, requestW, responseR, responseW] = map readFd fds - - closeFd requestW - closeFd responseR - requestR' <- fdToHandle requestR - responseW' <- fdToHandle responseW - - rpcServer' requestR' responseW' errorLog handler - --- | Start a concurrent conversation. -concurrentConversation :: FilePath -- ^ stdin named pipe - -> FilePath -- ^ stdout named pipe - -> FilePath -- ^ log file for exceptions - -> (FilePath -> RpcConversation -> IO ()) - -> IO () -concurrentConversation requestR responseW errorLog server = do - hin <- openPipeForReading requestR timeout - hout <- openPipeForWriting responseW timeout - rpcServer' hin hout errorLog server - where - timeout :: Int - timeout = maxBound - --- | Start the RPC server -rpcServer' :: Handle -- ^ Input - -> Handle -- ^ Output - -> FilePath -- ^ Log file for exceptions - -> (FilePath -> RpcConversation -> IO ()) -- ^ The request server - -> IO () -rpcServer' hin hout errorLog server = do - requests <- newChan :: IO (Chan BSL.ByteString) - responses <- newChan :: IO (Chan (Maybe BSL.ByteString)) - - setBinaryBlockBuffered [hin, hout] - - -- Each thread installs it own exception handler before unmasking - -- asynchronous exceptions. This way when an exception occurs we can - -- identify it (by looking at which ServerEvent was returned). - (reader, writer, handler) <- Ex.mask $ \restore -> do - reader <- async $ readRequests restore hin requests - writer <- async $ writeResponses restore responses hout - handler <- async $ channelHandler restore requests responses (server errorLog) - return (reader, writer, handler) - - (_thread, ev) <- $waitAny [reader, writer, handler] - case ev of - -- If we lose connection with the client, just terminate. - -- See #194 (in particular, https://github.com/fpco/ide-backend/issues/194#issuecomment-44210412) - LostConnection ex -> - tryShowException (Just ex) - - -- If the client requests termination, we simply terminate immediately. - -- It is the client's responsibility to have a proper shutdown protocol - -- with the server thread - ReaderThreadTerminated -> - return () - - -- The writer thread should never terminate normally unless we request - -- it; this is a logical impossibility :) - WriterThreadTerminated -> - error "The impossible happened" - - -- When the main server thread terminates we ask the writer thread to - -- terminate so that we make sure to send any pending messages - ServerThreadTerminated -> - tryShowException =<< flushResponses responses writer - - -- When the main server thread aborts, we still attempt to flush any - -- remaining messages, but the exception that we record is the one from - -- the server (the writer thread might terminate with a further exception) - ServerThreadAborted ex -> do - tryShowException (Just ex) - void $ flushResponses responses writer - - threadDelay 100000 - where - tryShowException :: Maybe Ex.SomeException -> IO () - tryShowException (Just ex) = - ignoreIOExceptions $ appendFile errorLog (show ex) - tryShowException Nothing = - return () - --------------------------------------------------------------------------------- --- Internal -- --------------------------------------------------------------------------------- - --- | We record the reason why the various threads are terminating, so that we --- can take the appropriate action -data ServerEvent = - -- | The reader thread terminates when the client sends a 'RequestShutdown' - -- message - ReaderThreadTerminated - - -- | After the main server thread terminates, we wait for the writer thread - -- to terminate to make sure there are no pending unsent messages - | WriterThreadTerminated - - -- | Termination of the main server thread - | ServerThreadTerminated - - -- | Main server thread threw an exception - | ServerThreadAborted Ex.SomeException - - -- | The reader thread and writer threads terminate with 'LostConnection' - -- if an exception occurs - | LostConnection Ex.SomeException - deriving Show - --- | Decode messages from a handle and forward them to a channel. --- The boolean result indicates whether the shutdown is forced. -readRequests :: Restore -> Handle -> Chan BSL.ByteString -> IO ServerEvent -readRequests restore h ch = - Ex.handle (return . LostConnection) - (restore (newStream h >>= go)) - where - go :: Stream Request -> IO ServerEvent - go input = do - req <- nextInStream input - case req of - Request req' -> writeChan ch (unIncBS req') >> go input - RequestShutdown -> return ReaderThreadTerminated - --- | Encode messages from a channel and forward them on a handle --- --- Terminates on 'Nothing'. -writeResponses :: Restore -> Chan (Maybe BSL.ByteString) -> Handle -> IO ServerEvent -writeResponses restore ch h = - Ex.handle (return . LostConnection) - (restore go) - where - go :: IO ServerEvent - go = do - mbs <- $readChan ch - case mbs of - Just bs -> do hPutFlush h $ encode (Response (IncBS bs)) ; go - Nothing -> return WriterThreadTerminated - --- | Ask the writer thread to terminate and wait for all remaining messages to --- have been sent. Returns 'Nothing' if the writer thread terminated normally, --- or the exception if it didn't. -flushResponses :: Chan (Maybe BSL.ByteString) -> Async ServerEvent -> IO (Maybe Ex.SomeException) -flushResponses responses writer = do - writeChan responses Nothing - ev <- $wait writer - case ev of - WriterThreadTerminated -> - return Nothing - LostConnection ex -> - return (Just ex) - _ -> - error "the impossible happened" - --- | Run a handler repeatedly, given input and output channels -channelHandler :: Restore - -> Chan BSL.ByteString - -> Chan (Maybe BSL.ByteString) - -> (RpcConversation -> IO ()) - -> IO ServerEvent -channelHandler restore requests responses server = - Ex.handle (return . ServerThreadAborted) - (restore go) - where - go :: IO ServerEvent - go = do - server RpcConversation { - get = $readChan requests >>= Ex.evaluate . decode - , put = writeChan responses . Just . encode - } - return ServerThreadTerminated - --------------------------------------------------------------------------------- --- Auxiliary -- --------------------------------------------------------------------------------- - -type Restore = forall a. IO a -> IO a - --- | Set all the specified handles to binary mode and block buffering -setBinaryBlockBuffered :: [Handle] -> IO () -setBinaryBlockBuffered = - mapM_ $ \h -> do hSetBinaryMode h True - hSetBuffering h (BlockBuffering Nothing) diff --git a/IdeSession/RPC/Stream.hs b/IdeSession/RPC/Stream.hs deleted file mode 100644 --- a/IdeSession/RPC/Stream.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Wrapper around binary -{-# LANGUAGE ScopedTypeVariables, GADTs #-} -module IdeSession.RPC.Stream ( - Stream - , newStream - , nextInStream - ) where - -import Prelude hiding (take) -import System.IO (Handle) -import qualified Control.Exception as Ex -import qualified Data.ByteString.Lazy.Internal as BSL -import qualified Data.ByteString as BSS -import Data.IORef (IORef, writeIORef, readIORef, newIORef) -import Data.Binary (Binary) -import qualified Data.Binary as Binary -import qualified Data.Binary.Get as Binary - -data Stream a where - Stream :: Binary a => Handle -> IORef (Binary.Decoder a) -> Stream a - -newStream :: Binary a => Handle -> IO (Stream a) -newStream h = do - st <- newIORef $ Binary.runGetIncremental Binary.get - return $ Stream h st - -nextInStream :: forall a. Stream a -> IO a -nextInStream (Stream h st) = readIORef st >>= go - where - go :: Binary.Decoder a -> IO a - go decoder = case decoder of - Binary.Fail _ _ err -> do - writeIORef st decoder - Ex.throwIO (userError err) - Binary.Partial k -> do - mchunk <- Ex.try $ BSS.hGetSome h BSL.defaultChunkSize - case mchunk of - Left ex -> do writeIORef st decoder - Ex.throwIO (ex :: Ex.SomeException) - Right chunk | BSS.null chunk -> go . k $ Nothing - | otherwise -> go . k $ Just chunk - Binary.Done unused _numConsumed a -> do - writeIORef st $ contDecoder unused - return a - - contDecoder :: BSS.ByteString -> Binary.Decoder a - contDecoder = Binary.pushChunk (Binary.runGetIncremental Binary.get) diff --git a/IdeSession/Strict/Container.hs b/IdeSession/Strict/Container.hs deleted file mode 100644 --- a/IdeSession/Strict/Container.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances, StandaloneDeriving #-} -module IdeSession.Strict.Container - ( StrictContainer(..) - , Strict(..) - -- * For convenience, we export the names of the lazy types too - , Maybe - , Map - , IntMap - , Trie - ) where - -import Control.Applicative -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.List as List -import Data.Trie (Trie) -import Data.Foldable as Foldable -import Data.Binary (Binary(..)) -import IdeSession.Util.PrettyVal - -class StrictContainer t where - data Strict (t :: * -> *) :: * -> * - force :: t a -> Strict t a - project :: Strict t a -> t a - -{------------------------------------------------------------------------------ - IntMap -------------------------------------------------------------------------------} - -instance StrictContainer IntMap where - newtype Strict IntMap v = StrictIntMap { toLazyIntMap :: IntMap v } - deriving Show - - force m = IntMap.foldl' (flip seq) () m `seq` StrictIntMap m - project = toLazyIntMap - -instance Binary v => Binary (Strict IntMap v) where - put = put . IntMap.toList . toLazyIntMap - get = (force . IntMap.fromList) <$> get - -instance PrettyVal v => PrettyVal (Strict IntMap v) where - prettyVal = prettyVal . toLazyIntMap - -{------------------------------------------------------------------------------ - Lists -------------------------------------------------------------------------------} - -instance StrictContainer [] where - newtype Strict [] a = StrictList { toLazyList :: [a] } - deriving (Show, Eq) - - force m = List.foldl' (flip seq) () m `seq` StrictList m - project = toLazyList - --- TODO: we can do better than this if we cache the length of the list -instance Binary a => Binary (Strict [] a) where - put = put . toLazyList - get = force <$> get - -instance PrettyVal a => PrettyVal (Strict [] a) where - prettyVal = prettyVal . toLazyList - -{------------------------------------------------------------------------------ - Map -------------------------------------------------------------------------------} - -instance StrictContainer (Map k) where - newtype Strict (Map k) v = StrictMap { toLazyMap :: Map k v } - deriving (Show) - - force m = Map.foldl' (flip seq) () m `seq` StrictMap m - project = toLazyMap - -instance (Ord k, Binary k, Binary v) => Binary (Strict (Map k) v) where - put = put . Map.toList . toLazyMap - get = (force . Map.fromList) <$> get - -instance (PrettyVal k, PrettyVal v) => PrettyVal (Strict (Map k) v) where - prettyVal = prettyVal . toLazyMap - -{------------------------------------------------------------------------------ - Maybe -------------------------------------------------------------------------------} - -instance StrictContainer Maybe where - newtype Strict Maybe a = StrictMaybe { toLazyMaybe :: Maybe a } - deriving (Show) - - force Nothing = StrictMaybe Nothing - force (Just x) = x `seq` StrictMaybe $ Just x - project = toLazyMaybe - -instance Binary a => Binary (Strict Maybe a) where - put = put . toLazyMaybe - get = force <$> get - -deriving instance Eq a => Eq (Strict Maybe a) -deriving instance Ord a => Ord (Strict Maybe a) - -instance Functor (Strict Maybe) where - fmap f = force . fmap f . toLazyMaybe - -instance PrettyVal a => PrettyVal (Strict Maybe a) where - prettyVal = prettyVal . toLazyMaybe - -instance Applicative (Strict Maybe) where - pure = force . pure - -- We need 'force' here because we need to force the result of the - -- function application - f <*> a = force $ toLazyMaybe f <*> toLazyMaybe a - -instance Alternative (Strict Maybe) where - empty = StrictMaybe Nothing - a <|> b = StrictMaybe $ toLazyMaybe a <|> toLazyMaybe b - -{------------------------------------------------------------------------------ - Trie -------------------------------------------------------------------------------} - -instance StrictContainer Trie where - newtype Strict Trie a = StrictTrie { toLazyTrie :: Trie a } - deriving (Show) - - force m = Foldable.foldl (flip seq) () m `seq` StrictTrie m - project = toLazyTrie - -instance PrettyVal a => PrettyVal (Strict Trie a) where - prettyVal = prettyVal . toLazyTrie diff --git a/IdeSession/Strict/IORef.hs b/IdeSession/Strict/IORef.hs deleted file mode 100644 --- a/IdeSession/Strict/IORef.hs +++ /dev/null @@ -1,28 +0,0 @@ --- IORefs that always evaluate their contents to WHNF -module IdeSession.Strict.IORef ( - StrictIORef -- Abstract - , newIORef - , readIORef - , writeIORef - , modifyIORef - ) where - -import Control.Applicative ((<$>)) -import Control.Exception (evaluate) -import Data.IORef (IORef) -import qualified Data.IORef as IORef - -newtype StrictIORef a = StrictIORef (IORef a) - -newIORef :: a -> IO (StrictIORef a) -newIORef x = StrictIORef <$> (evaluate x >>= IORef.newIORef) - -readIORef :: StrictIORef a -> IO a -readIORef (StrictIORef v) = IORef.readIORef v - -writeIORef :: StrictIORef a -> a -> IO () -writeIORef (StrictIORef v) x = evaluate x >>= IORef.writeIORef v - --- base 4.6 exports modifyIORef' but 4.5 does not. -modifyIORef :: StrictIORef a -> (a -> a) -> IO () -modifyIORef v f = readIORef v >>= writeIORef v . f diff --git a/IdeSession/Strict/IntMap.hs b/IdeSession/Strict/IntMap.hs deleted file mode 100644 --- a/IdeSession/Strict/IntMap.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances #-} --- | Wrapper around Data.IntMap that guarantees elements are evaluated when --- the Map is. containers-0.5 provides this out of the box, but alas ghc 7.4 --- is built against containers-0.4. -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} -module IdeSession.Strict.IntMap ( - fromList - , toList - , lookup - , findWithDefault - , empty - , adjust - , insertWith - , map - , reverseLookup - , filter - , filterWithKey - , union - ) where - -import Prelude hiding (map, filter, lookup) -import Data.Tuple (swap) -import qualified Data.IntMap as IntMap -import qualified Data.List as List - -import IdeSession.Strict.Container - -lookup :: Int -> Strict IntMap v -> Maybe v -lookup i = IntMap.lookup i . toLazyIntMap - -findWithDefault :: v -> Int -> Strict IntMap v -> v -findWithDefault def i = IntMap.findWithDefault def i . toLazyIntMap - -fromList :: [(Int, v)] -> Strict IntMap v -fromList = force . IntMap.fromList - -toList :: Strict IntMap v -> [(Int, v)] -toList = IntMap.toList . toLazyIntMap - -empty :: Strict IntMap v -empty = StrictIntMap $ IntMap.empty - --- We use alter because it gives us something to anchor a seq to -adjust :: forall v. (v -> v) -> Int -> Strict IntMap v -> Strict IntMap v -adjust f i = StrictIntMap . IntMap.alter aux i . toLazyIntMap - where - aux :: Maybe v -> Maybe v - aux Nothing = Nothing - aux (Just v) = let v' = f v in v' `seq` Just v' - -insertWith :: (v -> v -> v) -> Int -> v -> Strict IntMap v -> Strict IntMap v -insertWith f i v = StrictIntMap . IntMap.insertWith' f i v . toLazyIntMap - -map :: (a -> b) -> Strict IntMap a -> Strict IntMap b -map f = force . IntMap.map f . toLazyIntMap - --- O(n) -reverseLookup :: Eq v => Strict IntMap v -> v -> Maybe Int -reverseLookup m v = List.lookup v $ List.map swap $ toList m - -filter :: (v -> Bool) -> Strict IntMap v -> Strict IntMap v -filter p = StrictIntMap . IntMap.filter p . toLazyIntMap - -filterWithKey :: (Int -> v -> Bool) -> Strict IntMap v -> Strict IntMap v -filterWithKey p = StrictIntMap . IntMap.filterWithKey p . toLazyIntMap - -union :: Strict IntMap v -> Strict IntMap v -> Strict IntMap v -union a b = StrictIntMap $ IntMap.union (toLazyIntMap a) (toLazyIntMap b) diff --git a/IdeSession/Strict/IntervalMap.hs b/IdeSession/Strict/IntervalMap.hs deleted file mode 100644 --- a/IdeSession/Strict/IntervalMap.hs +++ /dev/null @@ -1,62 +0,0 @@ -module IdeSession.Strict.IntervalMap ( - StrictIntervalMap - , dominators - , fromList - , toList - , empty - , insert - -- * Re-exports - , Interval(..) - ) where - -import Data.IntervalMap.FingerTree (Interval(..), IntervalMap) -import qualified Data.IntervalMap.FingerTree as IntervalMap -import Text.Show.Pretty - -{- - We maintain an interval spanning the entire map, in order to support a toList - operation. --} - -data StrictIntervalMap v a = StrictIntervalMap { - toLazyIntervalMap :: !(IntervalMap v a) - , maxInterval :: !(Maybe (Interval v)) - } - -instance (Ord v, Show v, Show a) => Show (StrictIntervalMap v a) where - show m = "fromList " ++ show (toList m) - -instance (Ord v, PrettyVal v, PrettyVal a) => PrettyVal (StrictIntervalMap v a) where - prettyVal m = Con "fromList" [prettyVal . map flattenIntervals . toList $ m] - where - flattenIntervals :: (Interval v, a) -> ((v, v), a) - flattenIntervals (Interval lo hi, a) = ((lo, hi), a) - -unionInterval :: Ord v => Interval v -> Maybe (Interval v) -> Maybe (Interval v) -unionInterval i@(Interval low high) Nothing = - low `seq` high `seq` Just i -unionInterval (Interval low1 high1) (Just (Interval low2 high2)) = - let low = min low1 low2 - high = max high1 high2 - in low `seq` high `seq` Just (Interval low high) - -dominators :: Ord v => Interval v -> StrictIntervalMap v a -> [(Interval v, a)] -dominators i = IntervalMap.dominators i . toLazyIntervalMap - -empty :: Ord v => StrictIntervalMap v a -empty = StrictIntervalMap IntervalMap.empty Nothing - -insert :: Ord v => Interval v -> a -> StrictIntervalMap v a -> StrictIntervalMap v a -insert i a m = - a `seq` StrictIntervalMap { - toLazyIntervalMap = IntervalMap.insert i a $ toLazyIntervalMap m - , maxInterval = unionInterval i $ maxInterval m - } - -fromList :: Ord v => [(Interval v, a)] -> StrictIntervalMap v a -fromList = foldr (\(i, a) m -> insert i a m) empty - -toList :: Ord v => StrictIntervalMap v a -> [(Interval v, a)] -toList m = case maxInterval m of - Nothing -> [] - Just i -> IntervalMap.intersections i (toLazyIntervalMap m) diff --git a/IdeSession/Strict/List.hs b/IdeSession/Strict/List.hs deleted file mode 100644 --- a/IdeSession/Strict/List.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} --- | Strict lists -module IdeSession.Strict.List ( - nil - , cons - , singleton - , map - , all - , any - , reverse - , (++) - , elem - , (\\) - ) where - -import Prelude hiding (map, all, any, reverse, (++), elem) -import qualified Data.List as List - -import IdeSession.Strict.Container - -nil :: Strict [] a -nil = StrictList [] - -cons :: a -> Strict [] a -> Strict [] a -cons x xs = x `seq` StrictList (x : toLazyList xs) - -singleton :: a -> Strict [] a -singleton x = x `seq` StrictList [x] - -map :: (a -> b) -> Strict [] a -> Strict [] b -map f = force . List.map f . toLazyList - -all :: (a -> Bool) -> Strict [] a -> Bool -all p = List.all p . toLazyList - -any :: (a -> Bool) -> Strict [] a -> Bool -any p = List.any p . toLazyList - -elem :: Eq a => a -> Strict [] a -> Bool -elem x = List.elem x . toLazyList - -reverse :: Strict [] a -> Strict [] a -reverse = StrictList . List.reverse . toLazyList - -(++) :: Strict [] a -> Strict [] a -> Strict [] a -xs ++ ys = StrictList $ toLazyList xs List.++ toLazyList ys - -(\\) :: Eq a => Strict [] a -> Strict [] a -> Strict [] a -xs \\ ys = StrictList $ toLazyList xs List.\\ toLazyList ys diff --git a/IdeSession/Strict/MVar.hs b/IdeSession/Strict/MVar.hs deleted file mode 100644 --- a/IdeSession/Strict/MVar.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | MVar that always evaluates its argument to WHNF -module IdeSession.Strict.MVar ( - StrictMVar -- Abstract - , newEmptyMVar - , newMVar - , takeMVar - , putMVar - , readMVar - , swapMVar - , tryTakeMVar - , tryPutMVar - , isEmptyMVar - , withMVar - , modifyMVar_ - , modifyMVar - ) where - -import Control.Concurrent.MVar (MVar) -import qualified Control.Concurrent.MVar as MVar -import Control.Applicative ((<$>)) -import Control.Exception (evaluate) -import Control.Monad ((>=>)) - -newtype StrictMVar a = StrictMVar (MVar a) - -newEmptyMVar :: IO (StrictMVar a) -newEmptyMVar = StrictMVar <$> MVar.newEmptyMVar - -newMVar :: a -> IO (StrictMVar a) -newMVar x = StrictMVar <$> (evaluate x >>= MVar.newMVar) - -takeMVar :: StrictMVar a -> IO a -takeMVar (StrictMVar v) = MVar.takeMVar v - -putMVar :: StrictMVar a -> a -> IO () -putMVar (StrictMVar v) x = evaluate x >>= MVar.putMVar v - -readMVar :: StrictMVar a -> IO a -readMVar (StrictMVar v) = MVar.readMVar v - -swapMVar :: StrictMVar a -> a -> IO a -swapMVar (StrictMVar v) x = evaluate x >>= MVar.swapMVar v - -tryTakeMVar :: StrictMVar a -> IO (Maybe a) -tryTakeMVar (StrictMVar v) = MVar.tryTakeMVar v - -tryPutMVar :: StrictMVar a -> a -> IO Bool -tryPutMVar (StrictMVar v) x = evaluate x >>= MVar.tryPutMVar v - -isEmptyMVar :: StrictMVar a -> IO Bool -isEmptyMVar (StrictMVar v) = MVar.isEmptyMVar v - -withMVar :: StrictMVar a -> (a -> IO b) -> IO b -withMVar (StrictMVar v) f = MVar.withMVar v f - -modifyMVar_ :: StrictMVar a -> (a -> IO a) -> IO () -modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate) - -modifyMVar :: forall a b. StrictMVar a -> (a -> IO (a, b)) -> IO b -modifyMVar (StrictMVar v) f = MVar.modifyMVar v aux - where - aux :: a -> IO (a, b) - aux x = do (a, b) <- f x - a' <- evaluate a - return (a', b) diff --git a/IdeSession/Strict/Map.hs b/IdeSession/Strict/Map.hs deleted file mode 100644 --- a/IdeSession/Strict/Map.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} --- | Wrapper around Data.Map that guarantees elements are evaluated when --- the Map is. containers-0.5 provides this out of the box, but alas ghc 7.4 --- is built against containers-0.4. -module IdeSession.Strict.Map ( - toList - , fromList - , map - , mapWithKey - , mapKeys - , empty - , insert - , union - , unions - , filterWithKey - , lookup - , findWithDefault - , keysSet - , (\\) - , alter - , adjust - , member - , (!) - , keys - , elems - , delete - , accessor - , accessorDefault - ) where - -import Prelude hiding (map, lookup) -import Data.Set (Set) -import qualified Data.Map as Map -import Data.Accessor (Accessor) -import qualified Data.Accessor as Acc -import qualified Data.List as List - -import IdeSession.Strict.Container - -toList :: Strict (Map k) v -> [(k, v)] -toList = Map.toList . toLazyMap - -fromList :: Ord k => [(k, v)] -> Strict (Map k) v -fromList = force . Map.fromList - -map :: (a -> b) -> Strict (Map k) a -> Strict (Map k) b -map f = force . Map.map f . toLazyMap - -mapWithKey :: (k -> a -> b) -> Strict (Map k) a -> Strict (Map k) b -mapWithKey f = force . Map.mapWithKey f . toLazyMap - -mapKeys :: Ord k' => (k -> k') -> Strict (Map k) v -> Strict (Map k') v --- Maps are already strict in keys -mapKeys f = StrictMap . Map.mapKeys f . toLazyMap - -empty :: Strict (Map k) v -empty = StrictMap Map.empty - -insert :: Ord k => k -> v -> Strict (Map k) v -> Strict (Map k) v -insert k v = StrictMap . Map.insertWith' const k v . toLazyMap - --- | Left biased union -union :: Ord k => Strict (Map k) v -> Strict (Map k) v -> Strict (Map k) v -union a b = StrictMap $ Map.union (toLazyMap a) (toLazyMap b) - -unions :: Ord k => [Strict (Map k) v] -> Strict (Map k) v -unions = StrictMap . Map.unions . List.map toLazyMap - -filterWithKey :: Ord k => (k -> v -> Bool) -> Strict (Map k) v -> Strict (Map k) v -filterWithKey p = StrictMap . Map.filterWithKey p . toLazyMap - -keysSet :: Strict (Map k) v -> Set k -keysSet = Map.keysSet . toLazyMap - -lookup :: Ord k => k -> Strict (Map k) v -> Maybe v -lookup k = Map.lookup k . toLazyMap - -findWithDefault :: Ord k => v -> k -> Strict (Map k) v -> v -findWithDefault d k = Map.findWithDefault d k . toLazyMap - -(\\) :: Ord k => Strict (Map k) a -> Strict (Map k) b -> Strict (Map k) a -(\\) a b = StrictMap $ (Map.\\) (toLazyMap a) (toLazyMap b) - -alter :: forall k a. Ord k - => (Maybe a -> Maybe a) -> k -> Strict (Map k) a -> Strict (Map k) a -alter f k = StrictMap . Map.alter aux k . toLazyMap - where - aux :: Maybe a -> Maybe a - aux ma = case f ma of - Nothing -> Nothing - Just a -> a `seq` Just a - --- We use alter because it gives us something to anchor a seq to -adjust :: forall k v. Ord k => (v -> v) -> k -> Strict (Map k) v -> Strict (Map k) v -adjust f i = StrictMap . Map.alter aux i . toLazyMap - where - aux :: Maybe v -> Maybe v - aux Nothing = Nothing - aux (Just v) = let v' = f v in v' `seq` Just v' - -member :: Ord k => k -> Strict (Map k) v -> Bool -member k = Map.member k . toLazyMap - -(!) :: Ord k => Strict (Map k) v -> k -> v -(!) = (Map.!) . toLazyMap - -keys :: Strict (Map k) a -> [k] -keys = Map.keys . toLazyMap - -elems :: Strict (Map k) a -> [a] -elems = Map.elems . toLazyMap - -delete :: Ord k => k -> Strict (Map k) a -> Strict (Map k) a -delete k = StrictMap . Map.delete k . toLazyMap - -accessor :: Ord k => k -> Accessor (Strict (Map k) a) (Maybe a) -accessor key = Acc.accessor (lookup key) (\mval mp -> case mval of - Just val -> insert key val mp - Nothing -> delete key mp) - -accessorDefault :: Ord k => v -> k -> Accessor (Strict (Map k) v) v -accessorDefault d k = Acc.accessor (findWithDefault d k) (insert k) diff --git a/IdeSession/Strict/Maybe.hs b/IdeSession/Strict/Maybe.hs deleted file mode 100644 --- a/IdeSession/Strict/Maybe.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DeriveFunctor #-} --- | Version of maybe that is strict in its argument -module IdeSession.Strict.Maybe ( - nothing - , just - , maybe - , fromMaybe - ) where - -import Prelude hiding (maybe) -import IdeSession.Strict.Container -import qualified Data.Maybe as Maybe - -nothing :: Strict Maybe a -nothing = force $ Nothing - -just :: a -> Strict Maybe a -just = force . Just - -maybe :: b -> (a -> b) -> Strict Maybe a -> b -maybe x f = Maybe.maybe x f . toLazyMaybe - -fromMaybe :: a -> Strict Maybe a -> a -fromMaybe def = Maybe.fromMaybe def . toLazyMaybe diff --git a/IdeSession/Strict/StateT.hs b/IdeSession/Strict/StateT.hs deleted file mode 100644 --- a/IdeSession/Strict/StateT.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} --- | Version on StateT which evaluates the state strictly at every step -module IdeSession.Strict.StateT ( - -- * Transformer - StrictStateT(..) - , modify - , evalStateT - , execStateT - -- * As base monad - , StrictState - , runState - , evalState - , execState - ) where - -import Control.Applicative -import Control.Monad.State.Class -import Control.Monad.Trans.Class -import Data.Functor.Identity - -newtype StrictStateT s m a = StrictStateT { runStateT :: s -> m (a, s) } - -instance Monad m => Applicative (StrictStateT s m) where - pure = return - f <*> x = do f' <- f ; x' <- x ; return (f' x') - -instance Monad m => Monad (StrictStateT s m) where - return a = StrictStateT $ \s -> return (a, s) - x >>= f = StrictStateT $ \s -> do (a, s') <- runStateT x s - (b, s'') <- runStateT (f a) s' - return (b, s'') - -instance Monad m => Functor (StrictStateT s m) where - f `fmap` m = m >>= return . f - -instance Monad m => MonadState s (StrictStateT s m) where - get = StrictStateT $ \s -> return (s, s) - put s = StrictStateT $ \_ -> s `seq` return ((), s) - state f = StrictStateT $ \s -> do let (a, s') = f s - s' `seq` return (a, s') - -instance MonadTrans (StrictStateT s) where - lift m = StrictStateT $ \s -> do a <- m - return (a, s) - -evalStateT :: Monad m => StrictStateT s m a -> s -> m a -evalStateT m s = do (a, _) <- runStateT m s ; return a - -execStateT :: Monad m => StrictStateT s m a -> s -> m s -execStateT m s = do (_, s') <- runStateT m s ; return s' - -{------------------------------------------------------------------------------ - As base monad -------------------------------------------------------------------------------} - -type StrictState s = StrictStateT s Identity - -runState :: StrictState s a -> s -> (a, s) -runState m s = runIdentity $ runStateT m s - -evalState :: StrictState s a -> s -> a -evalState m = fst . runState m - -execState :: StrictState s a -> s -> s -execState m = snd . runState m diff --git a/IdeSession/Strict/Trie.hs b/IdeSession/Strict/Trie.hs deleted file mode 100644 --- a/IdeSession/Strict/Trie.hs +++ /dev/null @@ -1,27 +0,0 @@ -module IdeSession.Strict.Trie ( - empty - , submap - , elems - , fromListWith - , toList - ) where - -import Data.ByteString (ByteString) -import qualified Data.Trie as Trie -import qualified Data.Trie.Convenience as Trie -import IdeSession.Strict.Container - -empty :: Strict Trie a -empty = StrictTrie $ Trie.empty - -submap :: ByteString -> Strict Trie a -> Strict Trie a -submap bs = StrictTrie . Trie.submap bs . toLazyTrie - -elems :: Strict Trie a -> [a] -elems = Trie.elems . toLazyTrie - -fromListWith :: (a -> a -> a) -> [(ByteString, a)] -> Strict Trie a -fromListWith f = force . Trie.fromListWith f - -toList :: Strict Trie a -> [(ByteString, a)] -toList = Trie.toList . toLazyTrie diff --git a/IdeSession/Types/Private.hs b/IdeSession/Types/Private.hs deleted file mode 100644 --- a/IdeSession/Types/Private.hs +++ /dev/null @@ -1,411 +0,0 @@ -{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-} --- | The private types -module IdeSession.Types.Private ( - -- * Types without a public counterpart - FilePathPtr(..) - , IdPropPtr(..) - , UseSites - -- * Types with a public counterpart - , Public.IdNameSpace(..) - , IdInfo(..) - , IdProp(..) - , IdScope(..) - , SourceSpan(..) - , EitherSpan(..) - , SourceError(..) - , Public.SourceErrorKind(..) - , Public.ModuleName - , ModuleId(..) - , PackageId(..) - , IdList - , IdMap(..) - , ExpMap(..) - , SpanInfo(..) - , ImportEntities(..) - , Import(..) - , RunResult(..) - , BreakInfo(..) - -- * Cache - , ExplicitSharingCache(..) - , unionCache - -- * Util - , mkIdMap - , mkExpMap - , dominators - ) where - -import Prelude hiding (span, mod) -import Data.Text (Text) -import Data.ByteString (ByteString) -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (first) -import Data.Binary (Binary(..), getWord8, putWord8) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - -import qualified IdeSession.Types.Public as Public -import IdeSession.Strict.Container -import IdeSession.Strict.IntervalMap (StrictIntervalMap, Interval(..)) -import qualified IdeSession.Strict.IntervalMap as IntervalMap -import qualified IdeSession.Strict.IntMap as IntMap -import IdeSession.Util.PrettyVal - -newtype FilePathPtr = FilePathPtr { filePathPtr :: Int } - deriving (Eq, Ord, Show, Generic) - -newtype IdPropPtr = IdPropPtr { idPropPtr :: Int } - deriving (Eq, Ord, Show, Generic) - -data IdInfo = IdInfo { - idProp :: {-# UNPACK #-} !IdPropPtr - , idScope :: !IdScope - } - deriving (Show, Typeable, Generic) - -data IdProp = IdProp { - idName :: !Text - , idSpace :: !Public.IdNameSpace - , idType :: !(Strict Maybe Public.Type) - , idDefinedIn :: {-# UNPACK #-} !ModuleId - , idDefSpan :: !EitherSpan - , idHomeModule :: !(Strict Maybe ModuleId) - } - deriving (Show, Generic) - -data IdScope = - -- | This is a binding occurrence (@f x = ..@, @\x -> ..@, etc.) - Binder - -- | Defined within this module - | Local - -- | Imported from a different module - | Imported { - idImportedFrom :: {-# UNPACK #-} !ModuleId - , idImportSpan :: !EitherSpan - -- | Qualifier used for the import - -- - -- > IMPORTED AS idImportQual - -- > import Data.List "" - -- > import qualified Data.List "Data.List." - -- > import qualified Data.List as L "L." - , idImportQual :: !Text - } - -- | Wired into the compiler (@()@, @True@, etc.) - | WiredIn - deriving (Show, Generic) - -data SourceSpan = SourceSpan - { spanFilePath :: {-# UNPACK #-} !FilePathPtr - , spanFromLine :: {-# UNPACK #-} !Int - , spanFromColumn :: {-# UNPACK #-} !Int - , spanToLine :: {-# UNPACK #-} !Int - , spanToColumn :: {-# UNPACK #-} !Int - } - deriving (Eq, Ord, Show, Generic) - -data EitherSpan = - ProperSpan {-# UNPACK #-} !SourceSpan - | TextSpan !Text - deriving (Show, Generic) - -data SourceError = SourceError - { errorKind :: !Public.SourceErrorKind - , errorSpan :: !EitherSpan - , errorMsg :: !Text - } - deriving (Show, Generic) - -data ModuleId = ModuleId - { moduleName :: !Public.ModuleName - , modulePackage :: {-# UNPACK #-} !PackageId - } - deriving (Show, Eq, Generic) - -data PackageId = PackageId - { packageName :: !Text - , packageVersion :: !(Strict Maybe Text) - , packageKey :: !Text - } - deriving (Show, Eq, Ord, Generic) - --- | Used before we convert it to an IdMap -type IdList = [(SourceSpan, SpanInfo)] - -data SpanInfo = - SpanId IdInfo - | SpanQQ IdInfo - -- We use 'SpanInSplice' for prioritization only (see 'internalGetSpanInfo'). - -- It gets translated to 'Public.SpanId' - | SpanInSplice IdInfo - deriving (Show, Generic) - -newtype IdMap = IdMap { idMapToMap :: StrictIntervalMap (FilePathPtr, Int, Int) SpanInfo } - deriving (Show, Generic) - -newtype ExpMap = ExpMap { expMapToMap :: StrictIntervalMap (FilePathPtr, Int, Int) Text } - deriving (Show, Generic) - -type UseSites = Strict (Map IdPropPtr) [SourceSpan] - -data ImportEntities = - ImportOnly !(Strict [] Text) - | ImportHiding !(Strict [] Text) - | ImportAll - deriving (Show, Eq, Generic) - -data Import = Import { - importModule :: !ModuleId - -- | Used only for ghc's PackageImports extension - , importPackage :: !(Strict Maybe Text) - , importQualified :: !Bool - , importImplicit :: !Bool - , importAs :: !(Strict Maybe Public.ModuleName) - , importEntities :: !ImportEntities - } - deriving (Show, Eq, Generic) - --- | The outcome of running code -data RunResult = - -- | The code terminated okay - RunOk - -- | The code threw an exception - | RunProgException String - -- | GHC itself threw an exception when we tried to run the code - | RunGhcException String - -- | Execution was paused because of a breakpoint - | RunBreak BreakInfo - deriving (Typeable, Show, Generic) - --- | Information about a triggered breakpoint -data BreakInfo = BreakInfo { - breakInfoModule :: Public.ModuleName - , breakInfoSpan :: SourceSpan - , breakInfoResultType :: Public.Type - , breakInfoVariableEnv :: Public.VariableEnv - } - deriving (Typeable, Show, Generic) - -{------------------------------------------------------------------------------ - Cache -------------------------------------------------------------------------------} - --- TODO: Since the ExplicitSharingCache contains internal types, resolving --- references to the cache means we lose implicit sharing because we need --- to translate on every lookup. To avoid this, we'd have to introduce two --- versions of the cache and translate the entire cache first. -data ExplicitSharingCache = ExplicitSharingCache { - filePathCache :: !(Strict IntMap ByteString) - , idPropCache :: !(Strict IntMap IdProp) - } - deriving (Show, Generic) - -unionCache :: ExplicitSharingCache -> ExplicitSharingCache -> ExplicitSharingCache -unionCache a b = ExplicitSharingCache { - filePathCache = IntMap.union (filePathCache a) (filePathCache b) - , idPropCache = IntMap.union (idPropCache a) (idPropCache b) - } - -{------------------------------------------------------------------------------ - Binary instances -------------------------------------------------------------------------------} - -instance Binary FilePathPtr where - put = put . filePathPtr - get = FilePathPtr <$> get - -instance Binary SourceSpan where - put SourceSpan{..} = do - put spanFilePath - put spanFromLine - put spanFromColumn - put spanToLine - put spanToColumn - get = SourceSpan <$> get <*> get <*> get <*> get <*> get - -instance Binary EitherSpan where - put (ProperSpan span) = putWord8 0 >> put span - put (TextSpan text) = putWord8 1 >> put text - - get = do - header <- getWord8 - case header of - 0 -> ProperSpan <$> get - 1 -> TextSpan <$> get - _ -> fail "EitherSpan.get: invalid header" - -instance Binary SourceError where - put SourceError{..} = do - put errorKind - put errorSpan - put errorMsg - - get = SourceError <$> get <*> get <*> get - -instance Binary IdInfo where - put IdInfo{..} = put idProp >> put idScope - get = IdInfo <$> get <*> get - -instance Binary IdScope where - put Binder = putWord8 0 - put Local = do putWord8 1 - put Imported{..} = do putWord8 2 - put idImportedFrom - put idImportSpan - put idImportQual - put WiredIn = putWord8 3 - - get = do - header <- getWord8 - case header of - 0 -> return Binder - 1 -> return Local - 2 -> Imported <$> get <*> get <*> get - 3 -> return WiredIn - _ -> fail "IdScope.get: invalid header" - -instance Binary IdPropPtr where - put = put . idPropPtr - get = IdPropPtr <$> get - -instance Binary ModuleId where - put ModuleId{..} = put moduleName >> put modulePackage - get = ModuleId <$> get <*> get - -instance Binary PackageId where - put PackageId{..} = do - put packageName - put packageVersion - put packageKey - get = PackageId <$> get <*> get <*> get - -instance Binary IdProp where - put IdProp{..} = do - put idName - put idSpace - put idType - put idDefinedIn - put idDefSpan - put idHomeModule - - get = IdProp <$> get <*> get <*> get <*> get <*> get <*> get - -{- -instance Binary IdMap where - put = put . idMapToMap - get = IdMap <$> get --} - -instance Binary ImportEntities where - put (ImportOnly names) = putWord8 0 >> put names - put (ImportHiding names) = putWord8 1 >> put names - put ImportAll = putWord8 2 - - get = do - header <- getWord8 - case header of - 0 -> ImportOnly <$> get - 1 -> ImportHiding <$> get - 2 -> return ImportAll - _ -> fail "ImportEntities.get: invalid header" - -instance Binary Import where - put Import{..} = do - put importModule - put importPackage - put importQualified - put importImplicit - put importAs - put importEntities - - get = Import <$> get <*> get <*> get <*> get <*> get <*> get - -instance Binary ExplicitSharingCache where - put ExplicitSharingCache{..} = do - put filePathCache - put idPropCache - - get = ExplicitSharingCache <$> get <*> get - -instance Binary SpanInfo where - put (SpanId idInfo) = putWord8 0 >> put idInfo - put (SpanQQ idInfo) = putWord8 1 >> put idInfo - put (SpanInSplice idInfo) = putWord8 2 >> put idInfo - - get = do - header <- getWord8 - case header of - 0 -> SpanId <$> get - 1 -> SpanQQ <$> get - 2 -> SpanInSplice <$> get - _ -> fail "SpanInfo.get: invalid header" - -instance Binary RunResult where - put RunOk = putWord8 0 - put (RunProgException str) = putWord8 1 >> put str - put (RunGhcException str) = putWord8 2 >> put str - put (RunBreak info) = putWord8 3 >> put info - - get = do - header <- getWord8 - case header of - 0 -> return RunOk - 1 -> RunProgException <$> get - 2 -> RunGhcException <$> get - 3 -> RunBreak <$> get - _ -> fail "RunResult.get: invalid header" - -instance Binary BreakInfo where - put (BreakInfo{..}) = do - put breakInfoModule - put breakInfoSpan - put breakInfoResultType - put breakInfoVariableEnv - - get = BreakInfo <$> get <*> get <*> get <*> get - -{------------------------------------------------------------------------------ - PrettyVal instances (these rely on Generics) -------------------------------------------------------------------------------} - -instance PrettyVal FilePathPtr -instance PrettyVal IdPropPtr -instance PrettyVal IdInfo -instance PrettyVal IdProp -instance PrettyVal IdScope -instance PrettyVal SourceSpan -instance PrettyVal EitherSpan -instance PrettyVal SourceError -instance PrettyVal ModuleId -instance PrettyVal PackageId -instance PrettyVal SpanInfo -instance PrettyVal IdMap -instance PrettyVal ExpMap -instance PrettyVal ImportEntities -instance PrettyVal Import -instance PrettyVal RunResult -instance PrettyVal BreakInfo -instance PrettyVal ExplicitSharingCache - -{------------------------------------------------------------------------------ - Util -------------------------------------------------------------------------------} - -mkIdMap :: IdList -> IdMap -mkIdMap = IdMap . IntervalMap.fromList . map (first spanToInterval) - -mkExpMap :: [(SourceSpan, Text)] -> ExpMap -mkExpMap = ExpMap . IntervalMap.fromList . map (first spanToInterval) - -dominators :: SourceSpan -> StrictIntervalMap (FilePathPtr, Int, Int) a -> [(SourceSpan, a)] -dominators span ivalmap = - map (\(ival, idInfo) -> (intervalToSpan ival, idInfo)) - (IntervalMap.dominators (spanToInterval span) ivalmap) - -spanToInterval :: SourceSpan -> Interval (FilePathPtr, Int, Int) -spanToInterval SourceSpan{..} = - Interval (spanFilePath, spanFromLine, spanFromColumn) - (spanFilePath, spanToLine, spanToColumn) - -intervalToSpan :: Interval (FilePathPtr, Int, Int) -> SourceSpan -intervalToSpan (Interval (spanFilePath, spanFromLine, spanFromColumn) - (_, spanToLine, spanToColumn)) = - SourceSpan{..} diff --git a/IdeSession/Types/Progress.hs b/IdeSession/Types/Progress.hs deleted file mode 100644 --- a/IdeSession/Types/Progress.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module IdeSession.Types.Progress ( - Progress(..) - ) where - -import Control.Applicative ((<$>), (<*>), (<|>)) -import Data.Binary (Binary(..)) -import Data.Text (Text) -import Data.Maybe (fromJust) -import GHC.Generics (Generic) -import qualified Data.Text as Text -import Text.Show.Pretty (PrettyVal) - -import IdeSession.Util () -- instance Binary Text - --- | This type represents intermediate progress information during compilation. -data Progress = Progress { - -- | The current step number - -- - -- When these Progress messages are generated from progress updates from - -- ghc, it is entirely possible that we might get step 4/26, 16/26, 3/26; - -- the steps may not be continuous, might even be out of order, and may - -- not finish at X/X. - progressStep :: Int - - -- | The total number of steps - , progressNumSteps :: Int - - -- | The parsed message. For instance, in the case of progress messages - -- during compilation, 'progressOrigMsg' might be - -- - -- > [1 of 2] Compiling M (some/path/to/file.hs, some/other/path/to/file.o) - -- - -- while 'progressMsg' will just be 'Compiling M' - , progressParsedMsg :: Maybe Text - - -- | The full original message (see 'progressMsg') - , progressOrigMsg :: Maybe Text - } - deriving (Eq, Ord, Generic) - -instance PrettyVal Progress - -instance Binary Progress where - put (Progress {..}) = do put progressStep - put progressNumSteps - put progressParsedMsg - put progressOrigMsg - get = Progress <$> get <*> get <*> get <*> get - -instance Show Progress where - show (Progress{..}) = - "[" - ++ show progressStep - ++ " of " - ++ show progressNumSteps - ++ "]" - ++ fromJust (pad progressParsedMsg <|> pad progressOrigMsg <|> Just "") - where - pad :: Maybe Text -> Maybe String - pad = fmap $ \t -> " " ++ Text.unpack t diff --git a/IdeSession/Types/Public.hs b/IdeSession/Types/Public.hs deleted file mode 100644 --- a/IdeSession/Types/Public.hs +++ /dev/null @@ -1,571 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} --- | The public types -module IdeSession.Types.Public ( - -- * Types - IdNameSpace(..) - , Type - , Name - , IdInfo(..) - , IdProp(..) - , IdScope(..) - , SourceSpan(..) - , EitherSpan(..) - , SourceError(..) - , SourceErrorKind(..) - , ModuleName - , ModuleId(..) - , PackageId(..) --- , IdMap(..) --- , LoadedModules - , ImportEntities(..) - , Import(..) - , SpanInfo(..) - , RunBufferMode(..) - , RunResult(..) - , BreakInfo(..) - , Value - , VariableEnv - , Targets(..) - -- * Util - , idInfoQN ---, idInfoAtLocation - , haddockLink - ) where - -import Prelude hiding (span) -import Control.Applicative ((<$>), (<*>)) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Binary (Binary(..), getWord8, putWord8) -import Data.Aeson.TH (deriveJSON, defaultOptions) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - -import IdeSession.Util () -- Binary instance for Text -import IdeSession.Util.PrettyVal - -{------------------------------------------------------------------------------ - Types -------------------------------------------------------------------------------} - --- | Identifiers in Haskell are drawn from a number of different name spaces -data IdNameSpace = - VarName -- ^ Variables, including real data constructors - | DataName -- ^ Source data constructors - | TvName -- ^ Type variables - | TcClsName -- ^ Type constructors and classes - deriving (Show, Eq, Generic) - --- | Information about identifiers -data IdInfo = IdInfo { - idProp :: {-# UNPACK #-} !IdProp - , idScope :: !IdScope - } - deriving (Eq, Generic) - --- | Variable name -type Name = Text - --- | For now we represent types in pretty-printed form -type Type = Text - --- | Identifier info that is independent of the usage site -data IdProp = IdProp { - -- | The base name of the identifer at this location. Module prefix - -- is not included. - idName :: !Name - -- | Namespace this identifier is drawn from - , idSpace :: !IdNameSpace - -- | The type - -- We don't always know this; in particular, we don't know kinds because - -- the type checker does not give us LSigs for top-level annotations) - , idType :: !(Maybe Type) - -- | Module the identifier was defined in - , idDefinedIn :: {-# UNPACK #-} !ModuleId - -- | Where in the module was it defined (not always known) - , idDefSpan :: !EitherSpan - -- | Haddock home module - , idHomeModule :: !(Maybe ModuleId) - } - deriving (Eq, Generic) - --- TODO: Ideally, we would have --- 1. SourceSpan for Local rather than EitherSpan --- 2. SourceSpan for idImportSpan --- 3. Have a idImportedFromPackage, but unfortunately ghc doesn't give us --- this information (it's marked as a TODO in RdrName.lhs) -data IdScope = - -- | This is a binding occurrence (@f x = ..@, @\x -> ..@, etc.) - Binder - -- | Defined within this module - | Local - -- | Imported from a different module - | Imported { - idImportedFrom :: {-# UNPACK #-} !ModuleId - , idImportSpan :: !EitherSpan - -- | Qualifier used for the import - -- - -- > IMPORTED AS idImportQual - -- > import Data.List "" - -- > import qualified Data.List "Data.List." - -- > import qualified Data.List as L "L." - , idImportQual :: !Text - } - -- | Wired into the compiler (@()@, @True@, etc.) - | WiredIn - deriving (Eq, Generic) - -data SourceSpan = SourceSpan - { spanFilePath :: !FilePath - , spanFromLine :: {-# UNPACK #-} !Int - , spanFromColumn :: {-# UNPACK #-} !Int - , spanToLine :: {-# UNPACK #-} !Int - , spanToColumn :: {-# UNPACK #-} !Int - } - deriving (Eq, Ord, Generic) - -data EitherSpan = - ProperSpan {-# UNPACK #-} !SourceSpan - | TextSpan !Text - deriving (Eq, Generic) - --- | An error or warning in a source module. --- --- Most errors are associated with a span of text, but some have only a --- location point. -data SourceError = SourceError - { errorKind :: !SourceErrorKind - , errorSpan :: !EitherSpan - , errorMsg :: !Text - } - deriving (Show, Eq, Generic) - --- | Severity of an error. -data SourceErrorKind = KindError | KindWarning | KindServerDied - deriving (Show, Eq, Generic) - -type ModuleName = Text - -data ModuleId = ModuleId - { moduleName :: !ModuleName - , modulePackage :: {-# UNPACK #-} !PackageId - } - deriving (Eq, Ord, Generic) - --- | A package ID in ide-backend consists of a human-readable package name --- and version (what Cabal calls a source ID) along with ghc's internal --- package key (primarily for internal use). -data PackageId = PackageId - { packageName :: !Text - , packageVersion :: !(Maybe Text) - , packageKey :: !Text - } - deriving (Eq, Ord, Generic) - -{- -newtype IdMap = IdMap { idMapToMap :: Map SourceSpan IdInfo } - -type LoadedModules = Map ModuleName IdMap --} - -data ImportEntities = - ImportOnly ![Text] - | ImportHiding ![Text] - | ImportAll - deriving (Show, Eq, Ord, Generic) - -data Import = Import { - importModule :: !ModuleId - -- | Used only for ghc's PackageImports extension - , importPackage :: !(Maybe Text) - , importQualified :: !Bool - , importImplicit :: !Bool - , importAs :: !(Maybe ModuleName) - , importEntities :: !ImportEntities - } - deriving (Show, Eq, Ord, Generic) - --- | Returned then the IDE asks "what's at this particular location?" -data SpanInfo = - -- | Identifier - SpanId IdInfo - -- | Quasi-quote. The 'IdInfo' field gives the quasi-quoter - | SpanQQ IdInfo - deriving (Generic) - --- | Buffer modes for running code --- --- Note that 'NoBuffering' means that something like 'putStrLn' will do a --- syscall per character, and each of these characters will be read and sent --- back to the client. This results in a large overhead. --- --- When using 'LineBuffering' or 'BlockBuffering', 'runWait' will not report --- any output from the snippet until it outputs a linebreak/fills the buffer, --- respectively (or does an explicit flush). However, you can specify a timeout --- in addition to the buffering mode; if you set this to @Just n@, the buffer --- will be flushed every @n@ microseconds. --- --- NOTE: This is duplicated in the IdeBackendRTS (defined in IdeSession) -data RunBufferMode = - RunNoBuffering - | RunLineBuffering { runBufferTimeout :: Maybe Int } - | RunBlockBuffering { runBufferBlockSize :: Maybe Int - , runBufferTimeout :: Maybe Int - } - deriving (Typeable, Show, Generic, Eq) - --- | The outcome of running code -data RunResult = - -- | The code terminated okay - RunOk - -- | The code threw an exception - | RunProgException String - -- | GHC itself threw an exception when we tried to run the code - | RunGhcException String - -- | The session was restarted - | RunForceCancelled - -- | Execution was paused because of a breakpoint - | RunBreak - deriving (Typeable, Show, Eq, Generic) - --- | Information about a triggered breakpoint -data BreakInfo = BreakInfo { - -- | Module containing the breakpoint - breakInfoModule :: ModuleName - -- | Location of the breakpoint - , breakInfoSpan :: SourceSpan - -- | Type of the result - , breakInfoResultType :: Type - -- | Local variables and their values - , breakInfoVariableEnv :: VariableEnv - } - deriving (Typeable, Show, Eq, Generic) - --- | We present values only in pretty-printed form -type Value = Text - --- | Variables during execution (in debugging mode) -type VariableEnv = [(Name, Type, Value)] - -data Targets = TargetsInclude [FilePath] | TargetsExclude [FilePath] - deriving (Typeable, Generic, Eq, Show) - -{------------------------------------------------------------------------------ - Show instances -------------------------------------------------------------------------------} - -instance Show SourceSpan where - show (SourceSpan{..}) = - spanFilePath ++ "@" - ++ show spanFromLine ++ ":" ++ show spanFromColumn ++ "-" - ++ show spanToLine ++ ":" ++ show spanToColumn - -instance Show IdProp where - show (IdProp {..}) = - Text.unpack idName ++ " " - ++ "(" ++ show idSpace ++ ")" - ++ (case idType of Just typ -> " :: " ++ Text.unpack typ; Nothing -> []) - ++ " defined in " - ++ show idDefinedIn - ++ " at " ++ show idDefSpan - ++ (case idHomeModule of Just home -> " (home " ++ show home ++ ")" - Nothing -> "") - -instance Show IdScope where - show Binder = "binding occurrence" - show Local = "defined locally" - show WiredIn = "wired in to the compiler" - show (Imported {..}) = - "imported from " ++ show idImportedFrom - ++ (if Text.null idImportQual - then [] - else " as '" ++ Text.unpack idImportQual ++ "'") - ++ " at "++ show idImportSpan - -instance Show EitherSpan where - show (ProperSpan srcSpan) = show srcSpan - show (TextSpan str) = Text.unpack str - -instance Show ModuleId where - show (ModuleId mo pkg) = show pkg ++ ":" ++ Text.unpack mo - -instance Show PackageId where - show (PackageId name (Just version) _pkey) = - Text.unpack name ++ "-" ++ Text.unpack version - show (PackageId name Nothing _pkey) = - Text.unpack name - -instance Show IdInfo where - show IdInfo{..} = show idProp ++ " (" ++ show idScope ++ ")" - -instance Show SpanInfo where - show (SpanId idInfo) = show idInfo - show (SpanQQ idInfo) = "quasi-quote with quoter " ++ show idInfo - -{- -instance Show IdMap where - show = - let showIdInfo(span, idInfo) = "(" ++ show span ++ "," ++ show idInfo ++ ")" - in unlines . map showIdInfo . Map.toList . idMapToMap --} - -{------------------------------------------------------------------------------ - Binary instances - - We only have Binary instances for those types that are shared between - the public and private types, and for the "small" types that are the result of - IDE session queries. We don't want Binary instances for entire LoadedModules - maps and other "large" types. -------------------------------------------------------------------------------} - -instance Binary IdNameSpace where - put VarName = putWord8 0 - put DataName = putWord8 1 - put TvName = putWord8 2 - put TcClsName = putWord8 3 - - get = do - header <- getWord8 - case header of - 0 -> return VarName - 1 -> return DataName - 2 -> return TvName - 3 -> return TcClsName - _ -> fail "IdNameSpace.get: invalid header" - -instance Binary SourceErrorKind where - put KindError = putWord8 0 - put KindWarning = putWord8 1 - put KindServerDied = putWord8 2 - - get = do - header <- getWord8 - case header of - 0 -> return KindError - 1 -> return KindWarning - 2 -> return KindServerDied - _ -> fail "SourceErrorKind.get: invalid header" - -instance Binary ImportEntities where - put (ImportOnly names) = putWord8 0 >> put names - put (ImportHiding names) = putWord8 1 >> put names - put ImportAll = putWord8 2 - - get = do - header <- getWord8 - case header of - 0 -> ImportOnly <$> get - 1 -> ImportHiding <$> get - 2 -> return ImportAll - _ -> fail "ImportEntities.get: invalid header" - -instance Binary Import where - put Import{..} = do - put importModule - put importPackage - put importQualified - put importImplicit - put importAs - put importEntities - - get = Import <$> get <*> get <*> get <*> get <*> get <*> get - -instance Binary SourceError where - put SourceError{..} = do - put errorKind - put errorSpan - put errorMsg - - get = SourceError <$> get <*> get <*> get - -instance Binary IdProp where - put IdProp{..} = do - put idName - put idSpace - put idType - put idDefinedIn - put idDefSpan - put idHomeModule - - get = IdProp <$> get <*> get <*> get <*> get <*> get <*> get - -instance Binary IdScope where - put Binder = putWord8 0 - put Local = putWord8 1 - put Imported{..} = do putWord8 2 - put idImportedFrom - put idImportSpan - put idImportQual - put WiredIn = putWord8 3 - - get = do - header <- getWord8 - case header of - 0 -> return Binder - 1 -> return Local - 2 -> Imported <$> get <*> get <*> get - 3 -> return WiredIn - _ -> fail "IdScope.get: invalid header" - -instance Binary SourceSpan where - put (SourceSpan{..}) = do - put spanFilePath - put spanFromLine - put spanFromColumn - put spanToLine - put spanToColumn - - get = SourceSpan <$> get <*> get <*> get <*> get <*> get - -instance Binary EitherSpan where - put (ProperSpan span) = putWord8 0 >> put span - put (TextSpan text) = putWord8 1 >> put text - - get = do - header <- getWord8 - case header of - 0 -> ProperSpan <$> get - 1 -> TextSpan <$> get - _ -> fail "EitherSpan.get: invalid header" - -instance Binary ModuleId where - put ModuleId{..} = put moduleName >> put modulePackage - get = ModuleId <$> get <*> get - -instance Binary PackageId where - put PackageId{..} = do - put packageName - put packageVersion - put packageKey - get = PackageId <$> get <*> get <*> get - -instance Binary IdInfo where - put IdInfo{..} = put idProp >> put idScope - get = IdInfo <$> get <*> get - -instance Binary RunBufferMode where - put RunNoBuffering = putWord8 0 - put RunLineBuffering{..} = do putWord8 1 - put runBufferTimeout - put RunBlockBuffering{..} = do putWord8 2 - put runBufferBlockSize - put runBufferTimeout - - get = do - header <- getWord8 - case header of - 0 -> return RunNoBuffering - 1 -> RunLineBuffering <$> get - 2 -> RunBlockBuffering <$> get <*> get - _ -> fail "RunBufferMode.get: invalid header" - -instance Binary Targets where - put (TargetsInclude l) = do - putWord8 0 - put l - put (TargetsExclude l) = do - putWord8 1 - put l - - get = do - header <- getWord8 - case header of - 0 -> TargetsInclude <$> get - 1 -> TargetsExclude <$> get - _ -> fail "Targets.get: invalid header" - -{------------------------------------------------------------------------------ - JSON instances - - We provide these for the convenience of client code only; we don't use them - internally. -------------------------------------------------------------------------------} - -$(deriveJSON defaultOptions ''IdNameSpace) -$(deriveJSON defaultOptions ''SourceErrorKind) -$(deriveJSON defaultOptions ''ImportEntities) -$(deriveJSON defaultOptions ''Import) -$(deriveJSON defaultOptions ''SourceError) -$(deriveJSON defaultOptions ''IdProp) -$(deriveJSON defaultOptions ''IdScope) -$(deriveJSON defaultOptions ''SourceSpan) -$(deriveJSON defaultOptions ''EitherSpan) -$(deriveJSON defaultOptions ''ModuleId) -$(deriveJSON defaultOptions ''PackageId) -$(deriveJSON defaultOptions ''IdInfo) -$(deriveJSON defaultOptions ''SpanInfo) -$(deriveJSON defaultOptions ''BreakInfo) -$(deriveJSON defaultOptions ''RunResult) -$(deriveJSON defaultOptions ''RunBufferMode) - -{------------------------------------------------------------------------------ - PrettyVal instances (these rely on Generics) -------------------------------------------------------------------------------} - -instance PrettyVal IdNameSpace -instance PrettyVal IdInfo -instance PrettyVal IdProp -instance PrettyVal IdScope -instance PrettyVal SourceSpan -instance PrettyVal EitherSpan -instance PrettyVal SourceError -instance PrettyVal SourceErrorKind -instance PrettyVal ModuleId -instance PrettyVal PackageId -instance PrettyVal ImportEntities -instance PrettyVal Import -instance PrettyVal SpanInfo -instance PrettyVal RunBufferMode -instance PrettyVal RunResult -instance PrettyVal BreakInfo -instance PrettyVal Targets - -{------------------------------------------------------------------------------ - Util -------------------------------------------------------------------------------} - --- | Construct qualified name following Haskell's scoping rules -idInfoQN :: IdInfo -> String -idInfoQN IdInfo{idProp = IdProp{idName}, idScope} = - case idScope of - Binder -> Text.unpack idName - Local{} -> Text.unpack idName - Imported{idImportQual} -> Text.unpack idImportQual ++ Text.unpack idName - WiredIn -> Text.unpack idName - --- | Show approximately what Haddock adds to documentation URLs. -haddockSpaceMarks :: IdNameSpace -> String -haddockSpaceMarks VarName = "v" -haddockSpaceMarks DataName = "v" -haddockSpaceMarks TvName = "t" -haddockSpaceMarks TcClsName = "t" - --- | Show approximately a haddock link (without haddock root) for an id. --- This is an illustration and a test of the id info, but under ideal --- conditions could perhaps serve to link to documentation without --- going via Hoogle. -haddockLink :: IdProp -> IdScope -> String -haddockLink IdProp{..} idScope = - case idScope of - Imported{idImportedFrom} -> - dashToSlash (modulePackage idImportedFrom) - ++ "/doc/html/" - ++ dotToDash (Text.unpack $ moduleName idImportedFrom) ++ ".html#" - ++ haddockSpaceMarks idSpace ++ ":" - ++ Text.unpack idName - _ -> "" - where - dotToDash = map (\c -> if c == '.' then '-' else c) - dashToSlash p = case packageVersion p of - Nothing -> Text.unpack (packageName p) ++ "/latest" - Just version -> Text.unpack (packageName p) ++ "/" ++ Text.unpack version - -{- -idInfoAtLocation :: Int -> Int -> IdMap -> [(SourceSpan, IdInfo)] -idInfoAtLocation line col = filter inRange . idMapToList - where - inRange :: (SourceSpan, a) -> Bool - inRange (SourceSpan{..}, _) = - (line > spanFromLine || (line == spanFromLine && col >= spanFromColumn)) && - (line < spanToLine || (line == spanToLine && col <= spanToColumn)) --} diff --git a/IdeSession/Types/Translation.hs b/IdeSession/Types/Translation.hs deleted file mode 100644 --- a/IdeSession/Types/Translation.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} --- | Translation from the private to the public types -module IdeSession.Types.Translation ( - XShared - , ExplicitSharing(..) - , IntroduceSharing(..) - , showNormalized - , dereferenceFilePathPtr - ) where - -import Prelude hiding (mod, span) -import qualified Data.ByteString.Char8 as BSSC -import qualified Data.Text as Text -import Data.Binary (Binary) - -import IdeSession.Strict.Container -import qualified IdeSession.Types.Public as Public -import qualified IdeSession.Types.Private as Private -import qualified IdeSession.Strict.IntMap as StrictIntMap -import qualified IdeSession.Strict.Maybe as StrictMaybe - --- | The associated type with explicit sharing -type family XShared a - --- | The inverse of MShared, only for decidability of type checking -type family MShared a - -type instance XShared Public.IdProp = Private.IdProp -type instance XShared Public.IdInfo = Private.IdInfo -type instance XShared Public.IdScope = Private.IdScope -type instance XShared Public.SourceSpan = Private.SourceSpan -type instance XShared Public.EitherSpan = Private.EitherSpan -type instance XShared Public.SourceError = Private.SourceError --- type instance XShared Public.IdMap = Private.IdMap --- type instance XShared Public.LoadedModules = Private.LoadedModules -type instance XShared Public.ModuleId = Private.ModuleId -type instance XShared Public.PackageId = Private.PackageId -type instance XShared Public.ImportEntities = Private.ImportEntities -type instance XShared Public.Import = Private.Import -type instance XShared Public.SpanInfo = Private.SpanInfo -type instance XShared Public.RunResult = Private.RunResult -type instance XShared Public.BreakInfo = Private.BreakInfo - -type instance MShared Private.IdProp = Public.IdProp -type instance MShared Private.IdInfo = Public.IdInfo -type instance MShared Private.IdScope = Public.IdScope -type instance MShared Private.SourceSpan = Public.SourceSpan -type instance MShared Private.EitherSpan = Public.EitherSpan -type instance MShared Private.SourceError = Public.SourceError --- type instance MShared Private.IdMap = Public.IdMap --- type instance MShared Private.LoadedModules = Public.LoadedModules -type instance MShared Private.ModuleId = Public.ModuleId -type instance MShared Private.PackageId = Public.PackageId -type instance MShared Private.ImportEntities = Public.ImportEntities -type instance MShared Private.Import = Public.Import -type instance MShared Private.SpanInfo = Public.SpanInfo -type instance MShared Private.RunResult = Public.RunResult -type instance MShared Private.BreakInfo = Public.BreakInfo - -{------------------------------------------------------------------------------ - Removing explicit sharing -------------------------------------------------------------------------------} - --- | Many of the public data types that we export in "IdeSession" have a --- corresponding private @XShared@ version. For instance, we have @IdProp@ and --- @XShared IdProp@, @SourceError@ and @XShared SourceError@, etc. These --- @XShared@ types are abstract; what's important is only that they can be --- serialized (support @FromJSON@ and @ToJSON@). The main difference between --- the public and the private data types is that the private data types use --- explicit sharing. This is important for serialization, because there is --- quite a bit of sharing in the type information that we collect and losing --- this would be a significant performance hit. (The other difference is that --- the private data types use specialized types that guarantee strictness.) --- --- The @MShared (XShared a) ~ a@ condition on the @ExplicitSharing@ type class --- is there for technical reasons only (it convinces GHC that the @XShared@ --- type family is a bijection). -class (MShared (XShared a) ~ a, Binary (XShared a)) => ExplicitSharing a where - removeExplicitSharing :: Private.ExplicitSharingCache -> XShared a -> a - -showNormalized :: forall a. (Show a, ExplicitSharing a) - => Private.ExplicitSharingCache -> XShared a -> String -showNormalized cache x = show (removeExplicitSharing cache x :: a) - -instance ExplicitSharing Public.IdProp where - removeExplicitSharing cache Private.IdProp{..} = Public.IdProp { - Public.idName = idName - , Public.idSpace = idSpace - , Public.idType = toLazyMaybe idType - , Public.idDefSpan = removeExplicitSharing cache idDefSpan - , Public.idDefinedIn = removeExplicitSharing cache idDefinedIn - , Public.idHomeModule = StrictMaybe.maybe - Nothing - (Just . removeExplicitSharing cache) - idHomeModule - } - -instance ExplicitSharing Public.IdInfo where - removeExplicitSharing cache Private.IdInfo{..} = Public.IdInfo { - Public.idProp = case StrictIntMap.lookup (Private.idPropPtr idProp) - (Private.idPropCache cache) - of Just idProp' -> removeExplicitSharing cache idProp' - Nothing -> unknownProp - , Public.idScope = removeExplicitSharing cache idScope - } - where - unknownProp = Public.IdProp { - idName = Text.pack "<>" - , idSpace = Public.VarName - , idType = Nothing - , idDefinedIn = unknownModule - , idDefSpan = Public.TextSpan (Text.pack "<>") - , idHomeModule = Nothing - } - - unknownModule = Public.ModuleId { - moduleName = Text.pack "<>" - , modulePackage = unknownPackage - } - - unknownPackage = Public.PackageId { - packageName = Text.pack "<>" - , packageVersion = Nothing - , packageKey = Text.pack "<>" - } - -instance ExplicitSharing Public.ModuleId where - removeExplicitSharing cache Private.ModuleId{..} = Public.ModuleId { - Public.moduleName = moduleName - , Public.modulePackage = removeExplicitSharing cache modulePackage - } - -instance ExplicitSharing Public.PackageId where - removeExplicitSharing _cache Private.PackageId{..} = Public.PackageId { - Public.packageName = packageName - , Public.packageVersion = toLazyMaybe packageVersion - , Public.packageKey = packageKey - } - -instance ExplicitSharing Public.IdScope where - removeExplicitSharing cache idScope = case idScope of - Private.Binder -> Public.Binder - Private.Local -> Public.Local - Private.Imported {..} -> Public.Imported { - Public.idImportedFrom = removeExplicitSharing cache idImportedFrom - , Public.idImportSpan = removeExplicitSharing cache idImportSpan - , Public.idImportQual = idImportQual - } - Private.WiredIn -> Public.WiredIn - -instance ExplicitSharing Public.SourceSpan where - removeExplicitSharing cache Private.SourceSpan{..} = Public.SourceSpan { - Public.spanFilePath = dereferenceFilePathPtr cache spanFilePath - , Public.spanFromLine = spanFromLine - , Public.spanFromColumn = spanFromColumn - , Public.spanToLine = spanToLine - , Public.spanToColumn = spanToColumn - } - -instance ExplicitSharing Public.EitherSpan where - removeExplicitSharing cache eitherSpan = case eitherSpan of - Private.ProperSpan sourceSpan -> - Public.ProperSpan (removeExplicitSharing cache sourceSpan) - Private.TextSpan str -> - Public.TextSpan str - -instance ExplicitSharing Public.SourceError where - removeExplicitSharing cache Private.SourceError{..} = Public.SourceError { - Public.errorKind = errorKind - , Public.errorSpan = removeExplicitSharing cache errorSpan - , Public.errorMsg = errorMsg - } - -{- -instance ExplicitSharing Public.IdMap where - removeExplicitSharing cache = Public.IdMap - . toLazyMap - . StrictMap.map (removeExplicitSharing cache) - . StrictMap.mapKeys (removeExplicitSharing cache) - . Private.idMapToMap --} - -{- -instance ExplicitSharing Public.LoadedModules where - removeExplicitSharing cache = Map.map (removeExplicitSharing cache) - . toLazyMap --} - -instance ExplicitSharing Public.ImportEntities where - removeExplicitSharing _cache entities = case entities of - Private.ImportAll -> Public.ImportAll - Private.ImportHiding names -> Public.ImportHiding (toLazyList names) - Private.ImportOnly names -> Public.ImportOnly (toLazyList names) - -instance ExplicitSharing Public.Import where - removeExplicitSharing cache Private.Import{..} = Public.Import { - Public.importModule = removeExplicitSharing cache $ importModule - , Public.importPackage = toLazyMaybe importPackage - , Public.importQualified = importQualified - , Public.importImplicit = importImplicit - , Public.importAs = toLazyMaybe importAs - , Public.importEntities = removeExplicitSharing cache $ importEntities - } - -instance ExplicitSharing Public.SpanInfo where - removeExplicitSharing cache spanInfo = case spanInfo of - Private.SpanId idInfo -> Public.SpanId (removeExplicitSharing cache idInfo) - Private.SpanQQ idInfo -> Public.SpanQQ (removeExplicitSharing cache idInfo) - Private.SpanInSplice idInfo -> Public.SpanId (removeExplicitSharing cache idInfo) - -instance ExplicitSharing Public.BreakInfo where - removeExplicitSharing cache Private.BreakInfo{..} = Public.BreakInfo { - Public.breakInfoModule = breakInfoModule - , Public.breakInfoSpan = removeExplicitSharing cache breakInfoSpan - , Public.breakInfoResultType = breakInfoResultType - , Public.breakInfoVariableEnv = breakInfoVariableEnv - } - -{------------------------------------------------------------------------------ - Low-level API -------------------------------------------------------------------------------} - -dereferenceFilePathPtr :: Private.ExplicitSharingCache - -> Private.FilePathPtr -> FilePath -dereferenceFilePathPtr cache ptr = BSSC.unpack $ - StrictIntMap.findWithDefault - unknownFilePath - (Private.filePathPtr ptr) - (Private.filePathCache cache) - where - unknownFilePath = BSSC.pack "<>" - -{------------------------------------------------------------------------------ - Introducing explicit sharing -------------------------------------------------------------------------------} - --- | Introduce explicit sharing --- --- This provides the opposite translation to removeExplicitSharing. Note however --- that this is a partial function -- we never extend the cache, so if a --- required value is missing from the cache we return @Nothing@. -class IntroduceSharing a where - introduceExplicitSharing :: Private.ExplicitSharingCache -> a -> Maybe (XShared a) - -instance IntroduceSharing Public.SourceSpan where - introduceExplicitSharing cache Public.SourceSpan{..} = do - ptr <- StrictIntMap.reverseLookup (Private.filePathCache cache) - (BSSC.pack spanFilePath) - return Private.SourceSpan { - Private.spanFilePath = Private.FilePathPtr ptr - , Private.spanFromLine = spanFromLine - , Private.spanFromColumn = spanFromColumn - , Private.spanToLine = spanToLine - , Private.spanToColumn = spanToColumn - } diff --git a/IdeSession/Util.hs b/IdeSession/Util.hs deleted file mode 100644 --- a/IdeSession/Util.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DeriveFunctor, DeriveGeneric, StandaloneDeriving, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module IdeSession.Util ( - -- * Misc util - showExWithClass - , accessorName - , lookup' - , envWithPathOverride - , writeFileAtomic - , setupEnv - , relInclToOpts - , parseProgressMessage - , ignoreDoesNotExist - , interruptible - -- * Simple diffs - , Diff(..) - , applyMapDiff - -- * Manipulating stdout and stderr - , swizzleStdout - , swizzleStderr - , redirectStderr - , captureOutput - ) where - -import Control.Applicative ((<$>)) -import Control.Monad (void, forM_, mplus) -import Crypto.Classes (blockLength, initialCtx, updateCtx, finalize) -import Crypto.Types (BitLength) -import Data.Accessor (Accessor, accessor) -import Data.Binary (Binary(..)) -import Data.Char (isSpace) -import Data.Digest.Pure.MD5 (MD5Digest, MD5Context) -import Data.List (intercalate) -import Data.Maybe (fromMaybe) -import Data.Tagged (Tagged, untag) -import Data.Text (Text) -import Data.Typeable (typeOf) -import Foreign.C.Types (CFile) -import Foreign.Ptr (Ptr, castPtr, nullPtr) -import GHC.Generics (Generic) -import GHC.IO (unsafeUnmask) -import System.Directory (createDirectoryIfMissing, removeFile, renameFile) -import System.Environment (getEnvironment) -import System.FilePath (splitFileName, (<.>), ()) -import System.FilePath (splitSearchPath, searchPathSeparator) -import System.IO -import System.IO.Error (isDoesNotExistError) -import System.IO.Temp (withSystemTempFile) -import System.Posix (Fd) -import System.Posix.Env (setEnv, unsetEnv) -import System.Posix.IO -import System.Posix.Types (CPid(..)) -import Text.Show.Pretty -import qualified Control.Exception as Ex -import qualified Data.Attoparsec.Text as Att -import qualified Data.Binary as Bin -import qualified Data.Binary.Builder.Internal as Bin (writeN) -import qualified Data.Binary.Get.Internal as Bin (readNWith) -import qualified Data.Binary.Put as Bin (putBuilder) -import qualified Data.ByteString as BSS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Text as Text -import qualified Data.Text.Foreign as Text -import qualified System.Posix.Files as Files - -import IdeSession.Strict.Container -import qualified IdeSession.Strict.Map as StrictMap - -foreign import ccall "fflush" fflush :: Ptr CFile -> IO () - -{------------------------------------------------------------------------------ - Util -------------------------------------------------------------------------------} - --- | Show an exception together with its most precise type tag. -showExWithClass :: Ex.SomeException -> String -showExWithClass (Ex.SomeException ex) = show (typeOf ex) ++ ": " ++ show ex - --- | Translate record field '_name' to the accessor 'name' -accessorName :: String -> Maybe String -accessorName ('_' : str) = Just str -accessorName _ = Nothing - --- | Prelude.lookup as an accessor -lookup' :: Eq a => a -> Accessor [(a, b)] (Maybe b) -lookup' key = - accessor (lookup key) $ \mVal list -> - case mVal of - Nothing -> delete key list - Just val -> override key val list - where - override :: Eq a => a -> b -> [(a, b)] -> [(a, b)] - override a b [] = [(a, b)] - override a b ((a', b') : xs) - | a == a' = (a, b) : xs - | otherwise = (a', b') : override a b xs - - delete :: Eq a => a -> [(a, b)] -> [(a, b)] - delete _ [] = [] - delete a ((a', b') : xs) - | a == a' = xs - | otherwise = (a', b') : delete a xs - -envWithPathOverride :: [FilePath] -> IO (Maybe [(String, String)]) -envWithPathOverride [] = return Nothing -envWithPathOverride extraPathDirs = do - env <- getEnvironment - let path = fromMaybe "" (lookup "PATH" env) - path' = intercalate [searchPathSeparator] - (extraPathDirs ++ splitSearchPath path) - env' = ("PATH", path') : filter (\(var, _) -> var /= "PATH") env - return (Just env') - --- | Writes a file atomically. --- --- The file is either written successfully or an IO exception is raised and --- the original file is left unchanged. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- --- Returns the hash of the file; we are careful not to force the entire input --- bytestring into memory (we compute the hash as we write the file). -writeFileAtomic :: FilePath -> BSL.ByteString -> IO MD5Digest -writeFileAtomic targetPath content = do - let (targetDir, targetFile) = splitFileName targetPath - createDirectoryIfMissing True targetDir - Ex.bracketOnError - (openBinaryTempFile targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) - (\(tmpPath, handle) -> do - let bits :: Tagged MD5Digest BitLength ; bits = blockLength - hash <- go handle initialCtx $ makeBlocks (untag bits `div` 8) content - hClose handle - renameFile tmpPath targetPath - return hash) - where - go :: Handle -> MD5Context -> [BSS.ByteString] -> IO MD5Digest - go _ _ [] = error "Bug in makeBlocks" - go h ctx [bs] = BSS.hPut h bs >> return (finalize ctx bs) - go h ctx (bs:bss) = BSS.hPut h bs >> go h (updateCtx ctx bs) bss - --- | @makeBlocks n@ splits a bytestring into blocks with a size that is a --- multiple of 'n', with one left-over smaller bytestring at the end. --- --- Based from the (unexported) 'makeBlocks' in the crypto-api package, but --- we are careful to be as lazy as possible (the first -- block can be returned --- before the entire input bytestring is forced) -makeBlocks :: Int -> BSL.ByteString -> [BSS.ByteString] -makeBlocks n = go . BSL.toChunks - where - go [] = [BSS.empty] - go (bs:bss) - | BSS.length bs >= n = - let l = BSS.length bs - (BSS.length bs `rem` n) - (bsInit, bsTail) = BSS.splitAt l bs - in bsInit : go (bsTail : bss) - | otherwise = - case bss of - [] -> [bs] - (bs':bss') -> go (BSS.append bs bs' : bss') - --- | First restore the environment to the specified initial environment, then --- apply the given overrides -setupEnv :: [(String, String)] -> [(String, Maybe String)] -> IO () -setupEnv initEnv overrides = do - -- Delete everything in the current environment - curEnv <- getEnvironment - forM_ curEnv $ \(var, _val) -> unsetEnv var - - -- Restore initial environment - forM_ initEnv $ \(var, val) -> setEnv var val True - - -- Apply overrides - forM_ overrides $ \(var, mVal) -> - case mVal of - Just val -> setEnv var val True - Nothing -> unsetEnv var - -relInclToOpts :: FilePath -> [FilePath] -> [String] -relInclToOpts sourcesDir relIncl = - ["-i"] -- reset to empty - ++ map (\path -> "-i" ++ sourcesDir path) relIncl - -parseProgressMessage :: Text -> Either String (Int, Int, Text) -parseProgressMessage = Att.parseOnly parser - where - parser :: Att.Parser (Int, Int, Text) - parser = do - _ <- Att.char '[' ; Att.skipSpace - step <- Att.decimal ; Att.skipSpace - _ <- Att.string (Text.pack "of") ; Att.skipSpace - numS <- Att.decimal ; Att.skipSpace - _ <- Att.char ']' ; Att.skipSpace - rest <- parseCompiling `mplus` Att.takeText - return (step, numS, rest) - - parseCompiling :: Att.Parser Text - parseCompiling = do - compiling <- Att.string (Text.pack "Compiling") ; Att.skipSpace - _ <- parseTH ; Att.skipSpace - modName <- Att.takeTill isSpace - return $ Text.concat [compiling, Text.pack " ", modName] - - parseTH :: Att.Parser () - parseTH = Att.option () $ void $ Att.string (Text.pack "[TH]") - --- | Ignore "does not exist" exception -ignoreDoesNotExist :: IO () -> IO () -ignoreDoesNotExist = Ex.handle $ \e -> - if isDoesNotExistError e then return () - else Ex.throwIO e - --- | Define interruptiple operations --- --- (TODO: Stick in reference to blog post) -interruptible :: IO a -> IO a -interruptible act = do - st <- Ex.getMaskingState - case st of - Ex.Unmasked -> act - Ex.MaskedInterruptible -> unsafeUnmask act - Ex.MaskedUninterruptible -> act - -{------------------------------------------------------------------------------ - Simple diffs -------------------------------------------------------------------------------} - -data Diff a = Keep | Remove | Insert a - deriving (Show, Functor, Generic) - -instance Binary a => Binary (Diff a) where - put Keep = Bin.putWord8 0 - put Remove = Bin.putWord8 1 - put (Insert a) = Bin.putWord8 2 >> Bin.put a - - get = do - header <- Bin.getWord8 - case header of - 0 -> return Keep - 1 -> return Remove - 2 -> Insert <$> Bin.get - _ -> fail "Diff.get: invalid header" - -instance PrettyVal a => PrettyVal (Diff a) -- relies on Generics - -applyMapDiff :: forall k v. Ord k - => Strict (Map k) (Diff v) - -> Strict (Map k) v -> Strict (Map k) v -applyMapDiff diff = foldr (.) id (map aux $ StrictMap.toList diff) - where - aux :: (k, Diff v) -> Strict (Map k) v -> Strict (Map k) v - aux (_, Keep) = id - aux (k, Remove) = StrictMap.delete k - aux (k, Insert x) = StrictMap.insert k x - -{------------------------------------------------------------------------------- - Manipulations with stdout and stderr. --------------------------------------------------------------------------------} - -swizzleStdout :: Fd -> IO a -> IO a -swizzleStdout = swizzleHandle (stdout, stdOutput) - -swizzleStderr :: Fd -> IO a -> IO a -swizzleStderr = swizzleHandle (stderr, stdError) - -swizzleHandle :: (Handle, Fd) -> Fd -> IO a -> IO a -swizzleHandle (targetHandle, targetFd) fd act = - Ex.bracket swizzle unswizzle (\_ -> act) - where - swizzle :: IO Fd - swizzle = do - -- Flush existing handles - hFlush targetHandle - fflush nullPtr - - -- Backup stdout, then replace stdout with the given fd - backup <- dup targetFd - _ <- dupTo fd targetFd - - return backup - - unswizzle :: Fd -> IO () - unswizzle backup = do - -- Flush handles again - hFlush targetHandle - fflush nullPtr - - -- Restore stdout - _ <- dupTo backup targetFd - closeFd backup - -redirectStderr :: FilePath -> IO a -> IO a -redirectStderr fp act = do - Ex.bracket (openFd fp WriteOnly (Just mode) defaultFileFlags) - closeFd $ \errorLogFd -> - swizzleStderr errorLogFd $ - act - where - mode = Files.unionFileModes Files.ownerReadMode Files.ownerWriteMode - -captureOutput :: IO a -> IO (String, a) -captureOutput act = do - withSystemTempFile "suppressed" $ \fp handle -> do - fd <- handleToFd handle - a <- swizzleStdout fd . swizzleStderr fd $ act - closeFd fd - suppressed <- readFile fp - return (suppressed, a) - -{------------------------------------------------------------------------------- - Orphans --------------------------------------------------------------------------------} - -instance Binary Text where - get = do units <- Bin.get - Bin.readNWith (units * 2) $ \ptr -> - Text.fromPtr (castPtr ptr) (fromIntegral units) - - put t = do put (Text.lengthWord16 t) - Bin.putBuilder $ - Bin.writeN (Text.lengthWord16 t * 2) - (\p -> Text.unsafeCopyToPtr t (castPtr p)) - -deriving instance Binary CPid diff --git a/IdeSession/Util/BlockingOps.hs b/IdeSession/Util/BlockingOps.hs deleted file mode 100644 --- a/IdeSession/Util/BlockingOps.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE CPP, TemplateHaskell, NamedFieldPuns #-} --- | Blocking operations such as --- --- > readMVar v --- --- may throw an exception such as --- --- > thread blocked indefinitely in an MVar operation --- --- Unfortunately, this exception does not give any information of _where_ in --- the code we are blocked indefinitely. Compiling with profiling info and --- running with +RTC -xc can address this to some extent, but (1) it requires --- that all profiling libraries are installed and (2) when we are running --- multithreaded code the resulting stack trace is often difficult to read --- (and still does not include line numbers). With this module you can replace --- the above code with --- --- > $readMVar v --- --- and the exception that will be thrown is --- --- > YourModule:lineNumber: thread blocked indefinitely in an MVar operation --- --- which is a lot more informative. When the CPP flag DEBUGGING is turned off --- then @$readMVar@ just turns into @readMVar@. --- --- NOTE: The type of the exception changes when using DEBUGGING mode -- in order --- to be able to add the line number, all exceptions are turned into --- IOExceptions. -module IdeSession.Util.BlockingOps ( - -- * Generic debugging utilities - lineNumber - , traceOnException - , mapExceptionIO - , mapExceptionShow - -- * Blocking MVar ops - , putMVar - , takeMVar - , modifyMVar - , modifyMVar_ - , withMVar - , readMVar - , swapMVar - -- * Same for strict MVars - , putStrictMVar - , takeStrictMVar - , modifyStrictMVar - , modifyStrictMVar_ - , withStrictMVar - , readStrictMVar - , swapStrictMVar - -- * Blocking Chan ops - , readChan - -- * Blocking Async ops - , wait - , waitCatch - , waitAny - , waitAnyCatchCancel - ) where - -import Language.Haskell.TH -import qualified Control.Concurrent as C -import qualified Control.Concurrent.Async as Async -import System.IO (hPutStrLn, stderr) -import qualified Control.Exception as Ex - -import qualified IdeSession.Strict.MVar as StrictMVar - -lineNumber :: ExpQ -lineNumber = do - Loc{loc_module, loc_start=(line, _)} <- location - [| loc_module ++ ":" ++ show (line :: Int) |] - -mapExceptionIO :: (Ex.Exception e1, Ex.Exception e2) - => (e1 -> e2) -> IO a -> IO a -mapExceptionIO f io = Ex.catch io (Ex.throwIO . f) - -mapExceptionShow :: (String -> String) -> IO a -> IO a -mapExceptionShow f = mapExceptionIO (userError . f . showSomeException) - where - showSomeException :: Ex.SomeException -> String - showSomeException = show - -traceOnException :: String -> IO a -> IO a -traceOnException str io = Ex.catch io $ \e -> do - hPutStrLn stderr (str ++ ": " ++ show e) - Ex.throwIO (e :: Ex.SomeException) - -#define DEBUGGING 0 - -#if DEBUGGING == 1 - -rethrowWithLineNumber1 :: ExpQ -> ExpQ -rethrowWithLineNumber1 expr = - [| \arg1 -> mapExceptionShow (\e -> $lineNumber ++ ": " ++ e) - ($expr arg1) - |] - -rethrowWithLineNumber2 :: ExpQ -> ExpQ -rethrowWithLineNumber2 expr = - [| \arg1 arg2 -> mapExceptionShow (\e -> $lineNumber ++ ": " ++ e) - ($expr arg1 arg2) - |] - -{------------------------------------------------------------------------------- - MVar --------------------------------------------------------------------------------} - -takeMVar :: ExpQ -takeMVar = rethrowWithLineNumber1 [| C.takeMVar |] - -putMVar :: ExpQ -putMVar = rethrowWithLineNumber2 [| C.putMVar |] - -readMVar :: ExpQ -readMVar = rethrowWithLineNumber1 [| C.readMVar |] - -modifyMVar :: ExpQ -modifyMVar = rethrowWithLineNumber2 [| C.modifyMVar |] - -modifyMVar_ :: ExpQ -modifyMVar_ = rethrowWithLineNumber2 [| C.modifyMVar_ |] - -withMVar :: ExpQ -withMVar = rethrowWithLineNumber2 [| C.withMVar |] - -swapMVar :: ExpQ -swapMVar = rethrowWithLineNumber2 [| C.swapMVar |] - -{------------------------------------------------------------------------------- - StrictMVar --------------------------------------------------------------------------------} - -takeStrictMVar :: ExpQ -takeStrictMVar = rethrowWithLineNumber1 [| StrictMVar.takeMVar |] - -putStrictMVar :: ExpQ -putStrictMVar = rethrowWithLineNumber2 [| StrictMVar.putMVar |] - -readStrictMVar :: ExpQ -readStrictMVar = rethrowWithLineNumber1 [| StrictMVar.readMVar |] - -modifyStrictMVar :: ExpQ -modifyStrictMVar = rethrowWithLineNumber2 [| StrictMVar.modifyMVar |] - -modifyStrictMVar_ :: ExpQ -modifyStrictMVar_ = rethrowWithLineNumber2 [| StrictMVar.modifyMVar_ |] - -withStrictMVar :: ExpQ -withStrictMVar = rethrowWithLineNumber2 [| StrictMVar.withMVar |] - -swapStrictMVar :: ExpQ -swapStrictMVar = rethrowWithLineNumber2 [| StrictMVar.swapMVar |] - -{------------------------------------------------------------------------------- - Chan --------------------------------------------------------------------------------} - -readChan :: ExpQ -readChan = rethrowWithLineNumber1 [| C.readChan |] - -{------------------------------------------------------------------------------- - Async --------------------------------------------------------------------------------} - -wait :: ExpQ -wait = rethrowWithLineNumber1 [| Async.wait |] - -waitCatch :: ExpQ -waitCatch = rethrowWithLineNumber1 [| Async.waitCatch |] - -waitAny :: ExpQ -waitAny = rethrowWithLineNumber1 [| Async.waitAny |] - -waitAnyCatchCancel :: ExpQ -waitAnyCatchCancel = rethrowWithLineNumber1 [| Async.waitAnyCatchCancel |] - -#else - -{------------------------------------------------------------------------------- - MVar --------------------------------------------------------------------------------} - -takeMVar :: ExpQ -takeMVar = [| C.takeMVar |] - -putMVar :: ExpQ -putMVar = [| C.putMVar |] - -readMVar :: ExpQ -readMVar = [| C.readMVar |] - -modifyMVar :: ExpQ -modifyMVar = [| C.modifyMVar |] - -modifyMVar_ :: ExpQ -modifyMVar_ = [| C.modifyMVar_ |] - -withMVar :: ExpQ -withMVar = [| C.withMVar |] - -swapMVar :: ExpQ -swapMVar = [| C.swapMVar |] - -{------------------------------------------------------------------------------- - StrictMVar --------------------------------------------------------------------------------} - -takeStrictMVar :: ExpQ -takeStrictMVar = [| StrictMVar.takeMVar |] - -putStrictMVar :: ExpQ -putStrictMVar = [| StrictMVar.putMVar |] - -readStrictMVar :: ExpQ -readStrictMVar = [| StrictMVar.readMVar |] - -modifyStrictMVar :: ExpQ -modifyStrictMVar = [| StrictMVar.modifyMVar |] - -modifyStrictMVar_ :: ExpQ -modifyStrictMVar_ = [| StrictMVar.modifyMVar_ |] - -withStrictMVar :: ExpQ -withStrictMVar = [| StrictMVar.withMVar |] - -swapStrictMVar :: ExpQ -swapStrictMVar = [| StrictMVar.swapMVar |] - -{------------------------------------------------------------------------------- - Chan --------------------------------------------------------------------------------} - -readChan :: ExpQ -readChan = [| C.readChan |] - -{------------------------------------------------------------------------------- - Async --------------------------------------------------------------------------------} - -wait :: ExpQ -wait = [| Async.wait |] - -waitCatch :: ExpQ -waitCatch = [| Async.waitCatch |] - -waitAny :: ExpQ -waitAny = [| Async.waitAny |] - -waitAnyCatchCancel :: ExpQ -waitAnyCatchCancel = [| Async.waitAnyCatchCancel |] - -#endif diff --git a/IdeSession/Util/PrettyVal.hs b/IdeSession/Util/PrettyVal.hs deleted file mode 100644 --- a/IdeSession/Util/PrettyVal.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | (Orphan) PrettyVal instances for various standard datatypes -{-# OPTIONS_GHC -fno-warn-orphans #-} -module IdeSession.Util.PrettyVal ( - -- * Re-exports - PrettyVal(..) - ) where - -import Text.Show.Pretty -import Data.IntMap (IntMap) -import Data.Map (Map) -import Data.Trie (Trie) -import Data.ByteString (ByteString) -import Data.Text (Text) -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import qualified Data.Trie as Trie -import qualified Data.ByteString.Char8 as BSC -import qualified Data.Text as Text - -instance PrettyVal a => PrettyVal (Maybe a) where - prettyVal Nothing = Con "Nothing" [] - prettyVal (Just x) = Con "Just" [prettyVal x] - --- TODO: This has encoding issues -instance PrettyVal ByteString where - prettyVal = prettyVal . BSC.unpack - -instance PrettyVal a => PrettyVal (IntMap a) where - prettyVal m = Con "fromList" [prettyVal . IntMap.toList $ m] - -instance (PrettyVal k, PrettyVal a) => PrettyVal (Map k a) where - prettyVal m = Con "fromList" [prettyVal . Map.toList $ m] - -instance PrettyVal a => PrettyVal (Trie a) where - prettyVal m = Con "fromList" [prettyVal . Trie.toList $ m] - -instance PrettyVal Bool where - prettyVal True = Con "True" [] - prettyVal False = Con "False" [] - -instance PrettyVal Text where - prettyVal = prettyVal . Text.unpack diff --git a/ide-backend.cabal b/ide-backend.cabal --- a/ide-backend.cabal +++ b/ide-backend.cabal @@ -1,7 +1,7 @@ name: ide-backend -version: 0.9.0.1 +version: 0.9.0.2 synopsis: An IDE backend library --- description: +description: See README.md for more details license: MIT license-file: LICENSE author: Duncan Coutts, Mikolaj Konarski, Edsko de Vries @@ -24,30 +24,8 @@ IdeSession.Update, IdeSession.Update.IdeSessionUpdate, IdeSession.Update.ExecuteSessionUpdate, - IdeSession.RPC.Client, - IdeSession.RPC.API, - IdeSession.RPC.Stream, - IdeSession.Types.Public, - IdeSession.Types.Private, - IdeSession.Types.Translation, - IdeSession.Types.Progress, - IdeSession.GHC.API, - IdeSession.GHC.Requests, - IdeSession.GHC.Responses, - IdeSession.GHC.Client, - IdeSession.Util, - IdeSession.Util.BlockingOps, - IdeSession.Util.PrettyVal, - IdeSession.Strict.Container, - IdeSession.Strict.IntMap, - IdeSession.Strict.List, - IdeSession.Strict.Map, - IdeSession.Strict.Maybe, - IdeSession.Strict.Trie, - IdeSession.Strict.IntervalMap - IdeSession.Strict.MVar - IdeSession.Strict.IORef - IdeSession.Strict.StateT + IdeSession.GHC.Client + IdeSession.RPC.Client build-depends: base ==4.*, filemanip >= 0.3.6.2 && < 0.4, @@ -55,28 +33,21 @@ filepath >= 1.3 && < 1.5, directory >= 1.1 && < 1.3, containers >= 0.4.1 && < 1, - random >= 1.0.1 && < 2, bytestring >= 0.9.2 && < 1, mtl >= 2.1 && < 2.3, async >= 2.0 && < 2.1, - aeson >= 0.6.2 && < 0.9, - executable-path >= 0.0 && < 0.1, unix >= 2.5 && < 2.8, temporary >= 1.1.2.4 && < 1.3, - bytestring-trie >= 0.2 && < 0.3, - unordered-containers >= 0.2.3 && < 0.3, text >= 0.11 && < 1.3, - fingertree >= 0.0.1 && < 0.2, binary >= 0.7.1.0 && < 0.8, data-accessor >= 0.2 && < 0.3, data-accessor-mtl >= 0.2 && < 0.3, - crypto-api >= 0.12 && < 0.14, pureMD5 >= 2.1 && < 2.2, - tagged >= 0.4 && < 0.8, transformers >= 0.3 && < 0.5, time >= 1.4 && < 1.6, attoparsec >= 0.10 && < 0.13, utf8-string >= 0.3 && < 1.1, + ide-backend-common >= 0.9 && < 0.10, template-haskell, -- our own private fork: Cabal-ide-backend >= 1.23, @@ -100,9 +71,9 @@ ghc-options: -Wall -fno-warn-unused-do-bind executable ide-backend-exe-cabal - hs-source-dirs: . main-is: ide-backend-exe-cabal.hs build-depends: ide-backend, + ide-backend-common, base ==4.*, filemanip >= 0.3.6.2 && < 0.4, process >= 1.1 && < 1.3, @@ -147,7 +118,7 @@ type: exitcode-stdio-1.0 main-is: typecheck-dir.hs hs-source-dirs: test - build-depends: base, ide-backend, temporary, filemanip, directory, time, text + build-depends: base, ide-backend, ide-backend-common, temporary, filemanip, directory, time, text default-language: Haskell2010 default-extensions: MonoLocalBinds, @@ -198,6 +169,7 @@ TestTools build-depends: base, ide-backend, + ide-backend-common, tasty, HUnit, tagged, @@ -231,7 +203,7 @@ test-suite rpc-server type: exitcode-stdio-1.0 main-is: rpc-server.hs - hs-source-dirs: . server test + hs-source-dirs: . test build-depends: base ==4.*, directory ==1.*, filemanip >= 0.3.6.2 && < 0.4, @@ -249,6 +221,7 @@ executable-path >= 0.0 && < 0.1, unix >= 2.5 && < 2.8, binary >= 0.7.1.0 && < 0.8, + ide-backend-common, template-haskell default-language: Haskell2010 @@ -257,4 +230,3 @@ other-extensions: CPP, TemplateHaskell, ScopedTypeVariables, DeriveDataTypeable ghc-options: -Wall -fno-warn-unused-do-bind - other-modules: IdeSession.RPC.Server