hdevtools 0.1.0.3 → 0.1.0.4
raw patch · 4 files changed
+115/−50 lines, 4 files
Files
- hdevtools.cabal +27/−2
- src/CommandLoop.hs +83/−46
- src/Info.hs +2/−0
- src/Server.hs +3/−2
hdevtools.cabal view
@@ -1,7 +1,32 @@ name: hdevtools-version: 0.1.0.3+version: 0.1.0.4 synopsis: Persistent GHC powered background server for FAST haskell development tools--- description: +description:+ 'hdevtools' is a backend for text editor plugins, to allow for things such as+ syntax and type checking of Haskell code, and retrieving type information, all+ directly from within your text editor.+ .+ The advantage that 'hdevtools' has over competitors, is that it runs silently+ in a persistent background process, and therefore is able to keeps all of your+ Haskell modules and dependent libraries loaded in memory. This way, when you+ change only a single source file, only it needs to be reloaded and rechecked,+ instead of having to reload everything.+ .+ This makes 'hdevtools' very fast for checking syntax and type errors (runs just+ as fast as the ':reload' command in GHCi).+ .+ In fact, syntax and type checking is so fast, that you can safely enable auto+ checking on every save. Even for huge projects, checking is nearly instant.+ .+ Once you start using 'hdevtools' and you get used to having your errors shown+ to you instantly (without having to switch back and forth between GHCi and your+ editor), and shown directly on your code, in your editor (without having to+ wait forever for GHC to run) you will wonder how you ever lived without it.+ .+ In addition to checking Haskell source code for errors, 'hdevtools' has tools+ for getting info about identifiers, and getting type information for snippets+ of code.+ license: MIT license-file: LICENSE author: Bit Connor
src/CommandLoop.hs view
@@ -1,15 +1,18 @@ {-# LANGUAGE CPP #-} module CommandLoop- ( startCommandLoop+ ( newCommandLoopState+ , startCommandLoop ) where -import qualified ErrUtils-import GHC (Ghc, GhcException, GhcLink(NoLink), HscTarget(HscInterpreted), LoadHowMuch(LoadAllTargets), Severity, SrcSpan, SuccessFlag(Succeeded, Failed), gcatch, getSessionDynFlags, ghcLink, guessTarget, handleSourceError, hscTarget, load, log_action, noLoc, parseDynamicFlags, printException, runGhc, setSessionDynFlags, setTargets, showGhcException)-import qualified GHC-import GHC.Paths (libdir)+import Control.Monad (when)+import Data.IORef import MonadUtils (MonadIO, liftIO)-import Outputable (PprStyle, renderWithStyle) import System.Exit (ExitCode(ExitFailure, ExitSuccess))+import qualified ErrUtils+import qualified Exception (ExceptionMonad)+import qualified GHC+import qualified GHC.Paths+import qualified Outputable import Types (ClientDirective(..), Command(..)) import Info (getIdentifierInfo, getType)@@ -18,14 +21,36 @@ type ClientSend = ClientDirective -> IO () -startCommandLoop :: ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO ()-startCommandLoop clientSend getNextCommand initialGhcOpts mbInitial = do- continue <- runGhc (Just libdir) $ do- configOk <- gcatch (configSession clientSend initialGhcOpts >> return True)+data State = State+ { stateWarningsEnabled :: Bool+ }++newCommandLoopState :: IO (IORef State)+newCommandLoopState = do+ newIORef $ State+ { stateWarningsEnabled = True+ }++withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a+withWarnings state warningsValue action = do+ beforeState <- liftIO $ getWarnings+ liftIO $ setWarnings warningsValue+ action `GHC.gfinally`+ (liftIO $ setWarnings beforeState)+ where+ getWarnings :: IO Bool+ getWarnings = readIORef state >>= return . stateWarningsEnabled+ setWarnings :: Bool -> IO ()+ setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val }++startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO ()+startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do+ continue <- GHC.runGhc (Just GHC.Paths.libdir) $ do+ configOk <- GHC.gcatch (configSession state clientSend initialGhcOpts >> return True) handleConfigError if configOk then do- doMaybe mbInitial $ \cmd -> sendErrors (runCommand clientSend cmd)+ doMaybe mbInitial $ \cmd -> sendErrors (runCommand state clientSend cmd) processNextCommand False else processNextCommand True @@ -33,9 +58,9 @@ Nothing -> -- Exit return ()- Just (cmd, ghcOpts) -> startCommandLoop clientSend getNextCommand ghcOpts (Just cmd)+ Just (cmd, ghcOpts) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just cmd) where- processNextCommand :: Bool -> Ghc (Maybe CommandObj)+ processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) processNextCommand forceReconfig = do mbNextCmd <- liftIO getNextCommand case mbNextCmd of@@ -45,15 +70,15 @@ Just (cmd, ghcOpts) -> if forceReconfig || (ghcOpts /= initialGhcOpts) then return (Just (cmd, ghcOpts))- else sendErrors (runCommand clientSend cmd) >> processNextCommand False+ else sendErrors (runCommand state clientSend cmd) >> processNextCommand False - sendErrors :: Ghc () -> Ghc ()- sendErrors action = gcatch action (\x -> handleConfigError x >> return ())+ sendErrors :: GHC.Ghc () -> GHC.Ghc ()+ sendErrors action = GHC.gcatch action (\x -> handleConfigError x >> return ()) - handleConfigError :: GhcException -> Ghc Bool+ handleConfigError :: GHC.GhcException -> GHC.Ghc Bool handleConfigError e = do liftIO $ mapM_ clientSend- [ ClientStderr (showGhcException e "")+ [ ClientStderr (GHC.showGhcException e "") , ClientExit (ExitFailure 1) ] return False@@ -62,30 +87,31 @@ doMaybe Nothing _ = return () doMaybe (Just x) f = f x -configSession :: ClientSend -> [String] -> Ghc ()-configSession clientSend ghcOpts = do- initialDynFlags <- getSessionDynFlags+configSession :: IORef State -> ClientSend -> [String] -> GHC.Ghc ()+configSession state clientSend ghcOpts = do+ initialDynFlags <- GHC.getSessionDynFlags let updatedDynFlags = initialDynFlags- { log_action = logAction clientSend- , ghcLink = NoLink- , hscTarget = HscInterpreted+ { GHC.log_action = logAction state clientSend+ , GHC.ghcLink = GHC.NoLink+ , GHC.hscTarget = GHC.HscInterpreted }- (finalDynFlags, _, _) <- parseDynamicFlags updatedDynFlags (map noLoc ghcOpts)- _ <- setSessionDynFlags finalDynFlags+ (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts)+ _ <- GHC.setSessionDynFlags finalDynFlags return () -runCommand :: ClientSend -> Command -> Ghc ()-runCommand clientSend (CmdCheck file) = do+runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc ()+runCommand _ clientSend (CmdCheck file) = do let noPhase = Nothing- target <- guessTarget file noPhase- setTargets [target]- let handler err = printException err >> return Failed- flag <- handleSourceError handler (load LoadAllTargets)+ target <- GHC.guessTarget file noPhase+ GHC.setTargets [target]+ let handler err = GHC.printException err >> return GHC.Failed+ flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) liftIO $ case flag of- Succeeded -> clientSend (ClientExit ExitSuccess)- Failed -> clientSend (ClientExit (ExitFailure 1))-runCommand clientSend (CmdInfo file identifier) = do- result <- getIdentifierInfo file identifier+ GHC.Succeeded -> clientSend (ClientExit ExitSuccess)+ GHC.Failed -> clientSend (ClientExit (ExitFailure 1))+runCommand state clientSend (CmdInfo file identifier) = do+ result <- withWarnings state False $+ getIdentifierInfo file identifier case result of Left err -> liftIO $ mapM_ clientSend@@ -96,8 +122,9 @@ [ ClientStdout info , ClientExit ExitSuccess ]-runCommand clientSend (CmdType file (line, col)) = do- result <- getType file (line, col)+runCommand state clientSend (CmdType file (line, col)) = do+ result <- withWarnings state False $+ getType file (line, col) case result of Left err -> liftIO $ mapM_ clientSend@@ -119,17 +146,27 @@ ] #if __GLASGOW_HASKELL__ >= 706-logAction :: ClientSend -> GHC.DynFlags -> Severity -> SrcSpan -> PprStyle -> ErrUtils.MsgDoc -> IO ()-logAction clientSend dflags severity srcspan style msg =- let out = renderWithStyle dflags fullMsg style+logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO ()+logAction state clientSend dflags severity srcspan style msg =+ let out = Outputable.renderWithStyle dflags fullMsg style _ = severity- in clientSend (ClientStdout out)+ in logActionSend state clientSend severity out where fullMsg = ErrUtils.mkLocMessage severity srcspan msg #else-logAction :: ClientSend -> Severity -> SrcSpan -> PprStyle -> ErrUtils.Message -> IO ()-logAction clientSend severity srcspan style msg =- let out = renderWithStyle fullMsg style+logAction :: IORef State -> ClientSend -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.Message -> IO ()+logAction state clientSend severity srcspan style msg =+ let out = Outputable.renderWithStyle fullMsg style _ = severity- in clientSend (ClientStdout out)+ in logActionSend state clientSend severity out where fullMsg = ErrUtils.mkLocMessage srcspan msg #endif++logActionSend :: IORef State -> ClientSend -> GHC.Severity -> String -> IO ()+logActionSend state clientSend severity out = do+ currentState <- readIORef state+ when (not (isWarning severity) || stateWarningsEnabled currentState) $+ clientSend (ClientStdout out)+ where+ isWarning :: GHC.Severity -> Bool+ isWarning GHC.SevWarning = True+ isWarning _ = False
src/Info.hs view
@@ -13,7 +13,9 @@ import MonadUtils (liftIO) import qualified CoreUtils import qualified Desugar+#if __GLASGOW_HASKELL__ >= 706 import qualified DynFlags+#endif import qualified GHC import qualified HscTypes import qualified NameSet
src/Server.hs view
@@ -9,7 +9,7 @@ import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn) import System.IO.Error (isDoesNotExistError) -import CommandLoop (startCommandLoop)+import CommandLoop (newCommandLoopState, startCommandLoop) import Types (ClientDirective(..), Command, ServerDirective(..)) import Util (readMaybe) @@ -30,8 +30,9 @@ go :: Socket -> IO () go sock = do+ state <- newCommandLoopState currentClient <- newIORef Nothing- startCommandLoop (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing+ startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing removeSocketFile :: IO () removeSocketFile = do