diff --git a/IdeSession/GHC/API.hs b/IdeSession/GHC/API.hs new file mode 100644 --- /dev/null +++ b/IdeSession/GHC/API.hs @@ -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" diff --git a/IdeSession/GHC/Requests.hs b/IdeSession/GHC/Requests.hs new file mode 100644 --- /dev/null +++ b/IdeSession/GHC/Requests.hs @@ -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" diff --git a/IdeSession/GHC/Responses.hs b/IdeSession/GHC/Responses.hs new file mode 100644 --- /dev/null +++ b/IdeSession/GHC/Responses.hs @@ -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" diff --git a/IdeSession/RPC/API.hs b/IdeSession/RPC/API.hs new file mode 100644 --- /dev/null +++ b/IdeSession/RPC/API.hs @@ -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 diff --git a/IdeSession/RPC/Server.hs b/IdeSession/RPC/Server.hs new file mode 100644 --- /dev/null +++ b/IdeSession/RPC/Server.hs @@ -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) diff --git a/IdeSession/RPC/Stream.hs b/IdeSession/RPC/Stream.hs new file mode 100644 --- /dev/null +++ b/IdeSession/RPC/Stream.hs @@ -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) diff --git a/IdeSession/Strict/Container.hs b/IdeSession/Strict/Container.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Container.hs @@ -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 diff --git a/IdeSession/Strict/IORef.hs b/IdeSession/Strict/IORef.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/IORef.hs @@ -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 diff --git a/IdeSession/Strict/IntMap.hs b/IdeSession/Strict/IntMap.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/IntMap.hs @@ -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) diff --git a/IdeSession/Strict/IntervalMap.hs b/IdeSession/Strict/IntervalMap.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/IntervalMap.hs @@ -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) diff --git a/IdeSession/Strict/List.hs b/IdeSession/Strict/List.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/List.hs @@ -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 diff --git a/IdeSession/Strict/MVar.hs b/IdeSession/Strict/MVar.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/MVar.hs @@ -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) diff --git a/IdeSession/Strict/Map.hs b/IdeSession/Strict/Map.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Map.hs @@ -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) diff --git a/IdeSession/Strict/Maybe.hs b/IdeSession/Strict/Maybe.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Maybe.hs @@ -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 diff --git a/IdeSession/Strict/Pair.hs b/IdeSession/Strict/Pair.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Pair.hs @@ -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) diff --git a/IdeSession/Strict/StateT.hs b/IdeSession/Strict/StateT.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/StateT.hs @@ -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 diff --git a/IdeSession/Strict/Trie.hs b/IdeSession/Strict/Trie.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Trie.hs @@ -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 diff --git a/IdeSession/Types/Private.hs b/IdeSession/Types/Private.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Private.hs @@ -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{..} diff --git a/IdeSession/Types/Progress.hs b/IdeSession/Types/Progress.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Progress.hs @@ -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 diff --git a/IdeSession/Types/Public.hs b/IdeSession/Types/Public.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Public.hs @@ -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 + _ -> "" + where + dotToDash = map (\c -> if c == '.' then '-' else c) + dashToSlash p = case packageVersion p of + Nothing -> Text.unpack (packageName p) ++ "/latest" + Just version -> Text.unpack (packageName p) ++ "/" ++ Text.unpack version + +{- +idInfoAtLocation :: Int -> Int -> IdMap -> [(SourceSpan, IdInfo)] +idInfoAtLocation line col = filter inRange . idMapToList + where + inRange :: (SourceSpan, a) -> Bool + inRange (SourceSpan{..}, _) = + (line > spanFromLine || (line == spanFromLine && col >= spanFromColumn)) && + (line < spanToLine || (line == spanToLine && col <= spanToColumn)) +-} diff --git a/IdeSession/Types/Translation.hs b/IdeSession/Types/Translation.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Translation.hs @@ -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 "<>" + , idSpace = Public.VarName + , idType = Nothing + , idDefinedIn = unknownModule + , idDefSpan = Public.TextSpan (Text.pack "<>") + , idHomeModule = Nothing + } + + unknownModule = Public.ModuleId { + moduleName = Text.pack "<>" + , modulePackage = unknownPackage + } + + unknownPackage = Public.PackageId { + packageName = Text.pack "<>" + , packageVersion = Nothing + , packageKey = Text.pack "<>" + } + +instance ExplicitSharing Public.ModuleId where + removeExplicitSharing cache Private.ModuleId{..} = Public.ModuleId { + Public.moduleName = moduleName + , Public.modulePackage = removeExplicitSharing cache modulePackage + } + +instance ExplicitSharing Public.PackageId where + removeExplicitSharing _cache Private.PackageId{..} = Public.PackageId { + Public.packageName = packageName + , Public.packageVersion = toLazyMaybe packageVersion + , Public.packageKey = packageKey + } + +instance ExplicitSharing Public.IdScope where + removeExplicitSharing cache idScope = case idScope of + Private.Binder -> Public.Binder + Private.Local -> Public.Local + Private.Imported {..} -> Public.Imported { + Public.idImportedFrom = removeExplicitSharing cache idImportedFrom + , Public.idImportSpan = removeExplicitSharing cache idImportSpan + , Public.idImportQual = idImportQual + } + Private.WiredIn -> Public.WiredIn + +instance ExplicitSharing Public.SourceSpan where + removeExplicitSharing cache Private.SourceSpan{..} = Public.SourceSpan { + Public.spanFilePath = dereferenceFilePathPtr cache spanFilePath + , Public.spanFromLine = spanFromLine + , Public.spanFromColumn = spanFromColumn + , Public.spanToLine = spanToLine + , Public.spanToColumn = spanToColumn + } + +instance ExplicitSharing Public.EitherSpan where + removeExplicitSharing cache eitherSpan = case eitherSpan of + Private.ProperSpan sourceSpan -> + Public.ProperSpan (removeExplicitSharing cache sourceSpan) + Private.TextSpan str -> + Public.TextSpan str + +instance ExplicitSharing Public.SourceError where + removeExplicitSharing cache Private.SourceError{..} = Public.SourceError { + Public.errorKind = errorKind + , Public.errorSpan = removeExplicitSharing cache errorSpan + , Public.errorMsg = errorMsg + } + +{- +instance ExplicitSharing Public.IdMap where + removeExplicitSharing cache = Public.IdMap + . toLazyMap + . StrictMap.map (removeExplicitSharing cache) + . StrictMap.mapKeys (removeExplicitSharing cache) + . Private.idMapToMap +-} + +{- +instance ExplicitSharing Public.LoadedModules where + removeExplicitSharing cache = Map.map (removeExplicitSharing cache) + . toLazyMap +-} + +instance ExplicitSharing Public.ImportEntities where + removeExplicitSharing _cache entities = case entities of + Private.ImportAll -> Public.ImportAll + Private.ImportHiding names -> Public.ImportHiding (toLazyList names) + Private.ImportOnly names -> Public.ImportOnly (toLazyList names) + +instance ExplicitSharing Public.Import where + removeExplicitSharing cache Private.Import{..} = Public.Import { + Public.importModule = removeExplicitSharing cache $ importModule + , Public.importPackage = toLazyMaybe importPackage + , Public.importQualified = importQualified + , Public.importImplicit = importImplicit + , Public.importAs = toLazyMaybe importAs + , Public.importEntities = removeExplicitSharing cache $ importEntities + } + +instance ExplicitSharing Public.SpanInfo where + removeExplicitSharing cache spanInfo = case spanInfo of + Private.SpanId idInfo -> Public.SpanId (removeExplicitSharing cache idInfo) + Private.SpanQQ idInfo -> Public.SpanQQ (removeExplicitSharing cache idInfo) + Private.SpanInSplice idInfo -> Public.SpanId (removeExplicitSharing cache idInfo) + +instance ExplicitSharing Public.BreakInfo where + removeExplicitSharing cache Private.BreakInfo{..} = Public.BreakInfo { + Public.breakInfoModule = breakInfoModule + , Public.breakInfoSpan = removeExplicitSharing cache breakInfoSpan + , Public.breakInfoResultType = breakInfoResultType + , Public.breakInfoVariableEnv = breakInfoVariableEnv + } + +{------------------------------------------------------------------------------ + Low-level API +------------------------------------------------------------------------------} + +dereferenceFilePathPtr :: Private.ExplicitSharingCache + -> Private.FilePathPtr -> FilePath +dereferenceFilePathPtr cache ptr = BSSC.unpack $ + StrictIntMap.findWithDefault + unknownFilePath + (Private.filePathPtr ptr) + (Private.filePathCache cache) + where + unknownFilePath = BSSC.pack "<>" + +{------------------------------------------------------------------------------ + Introducing explicit sharing +------------------------------------------------------------------------------} + +-- | Introduce explicit sharing +-- +-- This provides the opposite translation to removeExplicitSharing. Note however +-- that this is a partial function -- we never extend the cache, so if a +-- required value is missing from the cache we return @Nothing@. +class IntroduceSharing a where + introduceExplicitSharing :: Private.ExplicitSharingCache -> a -> Maybe (XShared a) + +instance IntroduceSharing Public.SourceSpan where + introduceExplicitSharing cache Public.SourceSpan{..} = do + ptr <- StrictIntMap.reverseLookup (Private.filePathCache cache) + (BSSC.pack spanFilePath) + return Private.SourceSpan { + Private.spanFilePath = Private.FilePathPtr ptr + , Private.spanFromLine = spanFromLine + , Private.spanFromColumn = spanFromColumn + , Private.spanToLine = spanToLine + , Private.spanToColumn = spanToColumn + } diff --git a/IdeSession/Util.hs b/IdeSession/Util.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Util.hs @@ -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 diff --git a/IdeSession/Util/BlockingOps.hs b/IdeSession/Util/BlockingOps.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Util/BlockingOps.hs @@ -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 diff --git a/IdeSession/Util/PrettyVal.hs b/IdeSession/Util/PrettyVal.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Util/PrettyVal.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +## ide-backend-common + +Common shared library for ide-backend ide-backend-server diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ide-backend-common.cabal b/ide-backend-common.cabal new file mode 100644 --- /dev/null +++ b/ide-backend-common.cabal @@ -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 +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