ide-backend-common (empty) → 0.9.0
raw patch · 28 files changed
+3551/−0 lines, 28 filesdep +aesondep +asyncdep +attoparsecsetup-changed
Dependencies added: aeson, async, attoparsec, base, binary, bytestring, bytestring-trie, containers, crypto-api, data-accessor, directory, filepath, fingertree, mtl, pretty-show, pureMD5, tagged, template-haskell, temporary, text, transformers, unix
Files
- IdeSession/GHC/API.hs +90/−0
- IdeSession/GHC/Requests.hs +192/−0
- IdeSession/GHC/Responses.hs +127/−0
- IdeSession/RPC/API.hs +188/−0
- IdeSession/RPC/Server.hs +230/−0
- IdeSession/RPC/Stream.hs +47/−0
- IdeSession/Strict/Container.hs +130/−0
- IdeSession/Strict/IORef.hs +28/−0
- IdeSession/Strict/IntMap.hs +68/−0
- IdeSession/Strict/IntervalMap.hs +62/−0
- IdeSession/Strict/List.hs +49/−0
- IdeSession/Strict/MVar.hs +66/−0
- IdeSession/Strict/Map.hs +122/−0
- IdeSession/Strict/Maybe.hs +24/−0
- IdeSession/Strict/Pair.hs +14/−0
- IdeSession/Strict/StateT.hs +65/−0
- IdeSession/Strict/Trie.hs +27/−0
- IdeSession/Types/Private.hs +411/−0
- IdeSession/Types/Progress.hs +61/−0
- IdeSession/Types/Public.hs +571/−0
- IdeSession/Types/Translation.hs +255/−0
- IdeSession/Util.hs +325/−0
- IdeSession/Util/BlockingOps.hs +253/−0
- IdeSession/Util/PrettyVal.hs +42/−0
- LICENSE +21/−0
- README.md +3/−0
- Setup.hs +2/−0
- ide-backend-common.cabal +78/−0
+ IdeSession/GHC/API.hs view
@@ -0,0 +1,90 @@+-- | 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"
+ IdeSession/GHC/Requests.hs view
@@ -0,0 +1,192 @@+-- | 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"
+ IdeSession/GHC/Responses.hs view
@@ -0,0 +1,127 @@+-- | 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"
+ IdeSession/RPC/API.hs view
@@ -0,0 +1,188 @@+{-# 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
+ IdeSession/RPC/Server.hs view
@@ -0,0 +1,230 @@+{-# 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)
+ IdeSession/RPC/Stream.hs view
@@ -0,0 +1,47 @@+-- | 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)
+ IdeSession/Strict/Container.hs view
@@ -0,0 +1,130 @@+{-# 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
+ IdeSession/Strict/IORef.hs view
@@ -0,0 +1,28 @@+-- 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
+ IdeSession/Strict/IntMap.hs view
@@ -0,0 +1,68 @@+{-# 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)
+ IdeSession/Strict/IntervalMap.hs view
@@ -0,0 +1,62 @@+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)
+ IdeSession/Strict/List.hs view
@@ -0,0 +1,49 @@+{-# 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
+ IdeSession/Strict/MVar.hs view
@@ -0,0 +1,66 @@+{-# 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)
+ IdeSession/Strict/Map.hs view
@@ -0,0 +1,122 @@+{-# 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)
+ IdeSession/Strict/Maybe.hs view
@@ -0,0 +1,24 @@+{-# 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
+ IdeSession/Strict/Pair.hs view
@@ -0,0 +1,14 @@+-- | Strict pairs+--+-- Unfortunately, this doesn't fit into the Strict.Container hierarchy+-- (different kind)+module IdeSession.Strict.Pair (+ StrictPair+ , toLazyPair+ , fromLazyPair+ ) where++newtype StrictPair a b = StrictPair { toLazyPair :: (a, b) }++fromLazyPair :: (a, b) -> StrictPair a b+fromLazyPair (a, b) = a `seq` b `seq` StrictPair (a, b)
+ IdeSession/Strict/StateT.hs view
@@ -0,0 +1,65 @@+{-# 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
+ IdeSession/Strict/Trie.hs view
@@ -0,0 +1,27 @@+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
+ IdeSession/Types/Private.hs view
@@ -0,0 +1,411 @@+{-# 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{..}
+ IdeSession/Types/Progress.hs view
@@ -0,0 +1,61 @@+{-# 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
+ IdeSession/Types/Public.hs view
@@ -0,0 +1,571 @@+{-# 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+ _ -> "<local identifier>"+ 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))+-}
+ IdeSession/Types/Translation.hs view
@@ -0,0 +1,255 @@+{-# 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 "<<unknown id>>"+ , idSpace = Public.VarName+ , idType = Nothing+ , idDefinedIn = unknownModule+ , idDefSpan = Public.TextSpan (Text.pack "<<unknown span>>")+ , idHomeModule = Nothing+ }++ unknownModule = Public.ModuleId {+ moduleName = Text.pack "<<unknown module>>"+ , modulePackage = unknownPackage+ }++ unknownPackage = Public.PackageId {+ packageName = Text.pack "<<unknown package>>"+ , packageVersion = Nothing+ , packageKey = Text.pack "<<unknown package>>"+ }++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 "<<unknown filepath>>"++{------------------------------------------------------------------------------+ 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+ }
+ IdeSession/Util.hs view
@@ -0,0 +1,325 @@+{-# 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
+ IdeSession/Util/BlockingOps.hs view
@@ -0,0 +1,253 @@+{-# 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
+ IdeSession/Util/PrettyVal.hs view
@@ -0,0 +1,42 @@+-- | (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
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2015 FP Complete++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,3 @@+## ide-backend-common++Common shared library for ide-backend ide-backend-server
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ide-backend-common.cabal view
@@ -0,0 +1,78 @@+name: ide-backend-common+version: 0.9.0+synopsis: Shared library used be ide-backend and ide-backend-server+description: Should not be used by end users+license: MIT+license-file: LICENSE+author: Duncan Coutts, Mikolaj Konarski, Edsko de Vries+maintainer: Duncan Coutts <duncan@well-typed.com>+copyright: (c) 2015 FP Complete+category: Development+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md++library+ exposed-modules: IdeSession.Util+ IdeSession.Util.BlockingOps+ IdeSession.Util.PrettyVal+ IdeSession.GHC.API+ IdeSession.GHC.Requests+ IdeSession.GHC.Responses+ IdeSession.RPC.API+ IdeSession.RPC.Server+ IdeSession.RPC.Stream+ IdeSession.Strict.Container+ IdeSession.Strict.IntMap+ IdeSession.Strict.List+ IdeSession.Strict.Map+ IdeSession.Strict.Maybe+ IdeSession.Strict.Pair+ IdeSession.Strict.Trie+ IdeSession.Strict.IntervalMap+ IdeSession.Strict.MVar+ IdeSession.Strict.IORef+ IdeSession.Strict.StateT+ IdeSession.Types.Public+ IdeSession.Types.Private+ IdeSession.Types.Translation+ IdeSession.Types.Progress++ build-depends: base ==4.*,+ filepath >= 1.3 && < 1.5,+ directory >= 1.1 && < 1.3,+ containers >= 0.4.1 && < 1,+ bytestring >= 0.9.2 && < 1,+ mtl >= 2.1 && < 2.3,+ async >= 2.0 && < 2.1,+ aeson >= 0.6.2 && < 0.9,+ unix >= 2.5 && < 2.8,+ temporary >= 1.1.2.4 && < 1.3,+ bytestring-trie >= 0.2 && < 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,+ crypto-api >= 0.12 && < 0.14,+ pureMD5 >= 2.1 && < 2.2,+ tagged >= 0.4 && < 0.8,+ transformers >= 0.3 && < 0.5,+ attoparsec >= 0.10 && < 0.13,+ template-haskell,+ pretty-show++ default-language: Haskell2010+ default-extensions: MonoLocalBinds+ BangPatterns+ RecordWildCards+ NamedFieldPuns+ RankNTypes+ MultiParamTypeClasses+ ExistentialQuantification+ FlexibleContexts+ DeriveDataTypeable+ other-extensions: CPP+ TemplateHaskell+ ScopedTypeVariables,+ GeneralizedNewtypeDeriving+ ghc-options: -Wall -fno-warn-unused-do-bind