hdevtools 0.1.0.5 → 0.1.0.6
raw patch · 22 files changed
+433/−431 lines, 22 filesdep +Cabaldep +filepathnew-uploader
Dependencies added: Cabal, filepath
Files
- AUTHORS +0/−1
- README.md +0/−182
- hdevtools.cabal +13/−3
- src/Cabal.hs +195/−0
- src/Client.hs +5/−5
- src/CommandArgs.hs +12/−1
- src/CommandLoop.hs +90/−33
- src/Info.hs +37/−2
- src/Main.hs +51/−23
- src/Server.hs +17/−11
- src/Types.hs +13/−1
- test_all_hsenv.sh +0/−2
- test_hsenv.sh +0/−22
- tests/Child.hs +0/−6
- tests/Parent.hs +0/−4
- tests/SampleError.hs +0/−9
- tests/Simple.hs +0/−7
- tests/test_module_file.sh +0/−13
- tests/test_runner.sh +0/−59
- tests/test_sample_error.sh +0/−16
- tests/test_simple_check.sh +0/−11
- tests/test_start_stop.sh +0/−20
− AUTHORS
@@ -1,1 +0,0 @@-Bit Connor <mutantlemon@gmail.com>
− README.md
@@ -1,182 +0,0 @@-hdevtools-=========--Persistent GHC powered background server for FAST Haskell development tools--About--------`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.--Text Editor Integration--------------------------`hdevtools` is designed to be integrated into text editors. The list of current-editor plugins that supply this integration is below.--But before you do anything, you must first install `hdevtools` itself. The-easiest way is from [Hackage][1] via cabal install:-- $ cabal install hdevtools--Then you should install one or more of the following editor plugins:--### Vim - [Syntastic][2] ###--[Syntastic][2] is a popular syntax checking plugin for Vim, and is the-recommended Vim integration of `hdevtools` syntax and type checking. Recent-versions of Syntastic(since Sep. 2012) have builtin support for `hdevtools`.--Simply install `hdevtools` (as above) and [Syntastic][2], and it will-automatically check your Haskell files.--[Syntastic][2] will respect the `g:hdevtools_options` variable (the same one as-used by [vim-hdevtools][3], see below). See the section "Specifying GHC-Options" below for details how to use it.--### Vim - [vim-hdevtools][3] ###--In addition to Syntastic, it is recommended that you also use-[`vim-hdevtools`][3] for additional functionality.--[`vim-hdevtools`][3] offers integration with the rest of the `hdevtools` tools,-including retrieving info about the identifier under the cursor, and getting-the type of the code under the cursor. Refer to its documentation for more-details.--### Emacs ###--I encourage the community to develop integration plugins for Emacs and other-editors. In the mean time, please see the manual integration information below.--### Manual Editor Integration for any Editor ###--Most editors allow you to run a `make` command, and will then parse the output-for errors and show line numbers, allowing you to jump between errors.--The `hdevtools check` command is suitable for such usage.--For example, in Vim something like this will work:-- :let &makeprg='hdevtools check %'--(Vim will replace the `%` character with the name of the current file). Then-you can run-- :make--And Vim will invoke `hdevtools` to check the current file for errors, and then-show a list of them and allow jumping to them.--See the "Command Line Usage" section below for more information.--Command Line Usage---------------------Note: When using one of the above editor plugins, you don't really need to know-this.--### Available Commands and Help ###--For the list of commands available, run:-- $ hdevtools --help--To get help for a specific command, run:-- $ hdevtools [COMMAND] --help--For example:-- $ hdevtools check --help--### The `hdevtools` background process ###--The first time `hdevtools` runs a command, it will spawn a background process-that will remain running forever. You can check the status of this background-process by running:-- $ hdevtools --status--You can shutdown the background process by running:-- $ hdevtools --stop-server--Communication with the background process is done through a unix socket file.-The default name is `.hdevtools.sock`, in the current directory. This allows-you to use `hdevtools` with multiple projects simultaneously, without the-background processes getting in the way of each other.--You can use a different socket file name with the `--socket` option, which-should be used for each invocation of `hdevtools`. Remember that when telling-`hdevtools` to check a Haskell file, paths are relative to the path of the-background process, not your current directory. This can cause problems, and-therefore it is recommended that you leave the socket file as the default, and-always run `hdevtools` from the same directory.--### Specifying GHC Options ###--For most non-trivial projects, you will need to tell `hdevtools` about-additional GHC options that your project requires.--All `hdevtools` commands accept a `-g` flag for this purpose.--For example:--* Your project source code is in the directory `src`-* You want to use the GHC option `-Wall`-* You want to hide the package `transformers` to prevent conflicts--Invoke `hdevtools` with something like this:-- $ hdevtools check -g -isrc -g -Wall -g -hide-package -g transformers Foo.hs--Notice that a `-g` flag is inserted before each GHC option. Don't try to string-multiple GHC options together after a single `-g` flag:--This won't work:-- $ hdevtools check -g '-hide-package transformers' Foo.hs--The Vim plugins allow setting GHC options in the `g:hdevtools_options`-variable. For example, for the above project, put the following in your-`.vimrc`:-- let g:hdevtools_options = '-g -isrc -g -Wall -g -hide-package -g transformers'--In general, you will need to pass to `hdevtools` the same GHC options that you-would pass to GHCi.--Credits----------`hdevtools` was inspired by [ghcmod][4], but has the advantage that due to its-client-server architecture it is much faster.--[1]: http://hackage.haskell.org/package/hdevtools-[2]: https://github.com/scrooloose/syntastic-[3]: https://github.com/bitc/vim-hdevtools-[4]: http://www.mew.org/~kazu/proj/ghc-mod/en/
hdevtools.cabal view
@@ -1,5 +1,5 @@ name: hdevtools-version: 0.1.0.5+version: 0.1.0.6 synopsis: Persistent GHC powered background server for FAST haskell development tools description: 'hdevtools' is a backend for text editor plugins, to allow for things such as@@ -30,7 +30,7 @@ license: MIT license-file: LICENSE author: Bit Connor-maintainer: mutantlemon@gmail.com+maintainer: schell.scivally@synapsegroup.com copyright: See AUTHORS file category: Development homepage: https://github.com/bitc/hdevtools/@@ -47,7 +47,8 @@ ghc-options: -Wall cpp-options: -DCABAL main-is: Main.hs- other-modules: Client,+ other-modules: Cabal,+ Client, CommandArgs, CommandLoop, Daemonize,@@ -60,9 +61,18 @@ build-depends: base == 4.*, cmdargs, directory,+ filepath, ghc >= 7.2, ghc-paths, syb, network, time, unix++ if impl(ghc == 7.6.*)+ build-depends: Cabal == 1.16.*+ cpp-options: -DENABLE_CABAL++ if impl(ghc >= 7.7)+ build-depends: Cabal >= 1.18+ cpp-options: -DENABLE_CABAL
+ src/Cabal.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP #-}+module Cabal+ ( getPackageGhcOpts+ , findCabalFile+ ) where++#ifdef ENABLE_CABAL++import Control.Exception (IOException, catch)+import Data.Char (isSpace)+import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf)+import Data.Monoid (Monoid(..))+import Distribution.Package (PackageIdentifier(..), PackageName)+import Distribution.PackageDescription (PackageDescription(..), Executable(..), TestSuite(..), Benchmark(..), emptyHookedBuildInfo, buildable, libBuildInfo)+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Simple.Configure (configure)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), ComponentLocalBuildInfo(..),+ Component(..), ComponentName(..),+#if __GLASGOW_HASKELL__ < 707+ allComponentsBy,+#endif+ componentBuildInfo, foldComponent)+import Distribution.Simple.Compiler (PackageDB(..))+import Distribution.Simple.GHC (componentGhcOptions)+import Distribution.Simple.Program (defaultProgramConfiguration)+import Distribution.Simple.Program.Db (lookupProgram)+import Distribution.Simple.Program.Types (ConfiguredProgram(programVersion), simpleProgram)+import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions)+import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, toFlag)+import Distribution.Verbosity (silent)+import Distribution.Version (Version(..))++import System.IO.Error (ioeGetErrorString)+import System.Directory (doesFileExist, getDirectoryContents)+import System.FilePath (takeDirectory, splitFileName, (</>))++componentName :: Component -> ComponentName+componentName =+ foldComponent (const CLibName)+ (CExeName . exeName)+ (CTestName . testName)+ (CBenchName . benchmarkName)++getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo+#if __GLASGOW_HASKELL__ >= 707+getComponentLocalBuildInfo lbi cname = getLocalBuildInfo cname $ componentsConfigs lbi+ where getLocalBuildInfo cname' ((cname'', clbi, _):cfgs) =+ if cname' == cname'' then clbi else getLocalBuildInfo cname' cfgs+ getLocalBuildInfo _ [] = error $ "internal error: missing config"+#else+getComponentLocalBuildInfo lbi CLibName =+ case libraryConfig lbi of+ Nothing -> error $ "internal error: missing library config"+ Just clbi -> clbi+getComponentLocalBuildInfo lbi (CExeName name) =+ case lookup name (executableConfigs lbi) of+ Nothing -> error $ "internal error: missing config for executable " ++ name+ Just clbi -> clbi+getComponentLocalBuildInfo lbi (CTestName name) =+ case lookup name (testSuiteConfigs lbi) of+ Nothing -> error $ "internal error: missing config for test suite " ++ name+ Just clbi -> clbi+getComponentLocalBuildInfo lbi (CBenchName name) =+ case lookup name (testSuiteConfigs lbi) of+ Nothing -> error $ "internal error: missing config for benchmark " ++ name+ Just clbi -> clbi+#endif++#if __GLASGOW_HASKELL__ >= 707+-- TODO: Fix callsites so we don't need `allComponentsBy`. It was taken from+-- http://hackage.haskell.org/package/Cabal-1.16.0.3/docs/src/Distribution-Simple-LocalBuildInfo.html#allComponentsBy+-- since it doesn't exist in Cabal 1.18.*+--+-- | Obtains all components (libs, exes, or test suites), transformed by the+-- given function. Useful for gathering dependencies with component context.+allComponentsBy :: PackageDescription+ -> (Component -> a)+ -> [a]+allComponentsBy pkg_descr f =+ [ f (CLib lib) | Just lib <- [library pkg_descr]+ , buildable (libBuildInfo lib) ]+ ++ [ f (CExe exe) | exe <- executables pkg_descr+ , buildable (buildInfo exe) ]+ ++ [ f (CTest tst) | tst <- testSuites pkg_descr+ , buildable (testBuildInfo tst)+ , testEnabled tst ]+ ++ [ f (CBench bm) | bm <- benchmarks pkg_descr+ , buildable (benchmarkBuildInfo bm)+ , benchmarkEnabled bm ]+#endif+++getPackageGhcOpts :: FilePath -> IO (Either String [String])+getPackageGhcOpts path = do+ getPackageGhcOpts' `catch` (\e -> do+ return $ Left $ "Cabal error: " ++ (ioeGetErrorString (e :: IOException)))+ where+ getPackageGhcOpts' :: IO (Either String [String])+ getPackageGhcOpts' = do+ genPkgDescr <- readPackageDescription silent path++ let cfgFlags' = (defaultConfigFlags defaultProgramConfiguration)+ { configDistPref = toFlag $ takeDirectory path </> "dist"+ -- TODO: figure out how to find out this flag+ , configUserInstall = toFlag True+ }++ let sandboxConfig = takeDirectory path </> "cabal.sandbox.config"+ exists <- doesFileExist sandboxConfig++ cfgFlags <- case exists of+ False -> return cfgFlags'+ True -> do+ sandboxPackageDb <- getSandboxPackageDB sandboxConfig+ return $ cfgFlags'+ { configPackageDBs = [Just sandboxPackageDb]+ }++ localBuildInfo <- configure (genPkgDescr, emptyHookedBuildInfo) cfgFlags++ let pkgDescr = localPkgDescr localBuildInfo+ let baseDir = fst . splitFileName $ path+ case getGhcVersion localBuildInfo of+ Nothing -> return $ Left "GHC is not configured"+ Just ghcVersion -> do+ let mbLibName = pkgLibName pkgDescr++ let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo+ -- FIX bug in GhcOptions' `mappend`+ ghcOpts = ghcOpts' { ghcOptExtra = filter (/= "-Werror") $ nub $ ghcOptExtra ghcOpts'+ , ghcOptPackageDBs = sort $ nub (ghcOptPackageDBs ghcOpts')+ , ghcOptPackages = filter (\(_, pkgId) -> Just (pkgName pkgId) /= mbLibName) $ nub (ghcOptPackages ghcOpts')+ , ghcOptSourcePath = map (baseDir </>) (ghcOptSourcePath ghcOpts')+ }++ return $ Right $ renderGhcOptions ghcVersion ghcOpts++ pkgLibName :: PackageDescription -> Maybe PackageName+ pkgLibName pkgDescr = if hasLibrary pkgDescr+ then Just $ pkgName . package $ pkgDescr+ else Nothing++ hasLibrary :: PackageDescription -> Bool+ hasLibrary = maybe False (\_ -> True) . library++ getComponentGhcOptions :: LocalBuildInfo -> Component -> GhcOptions+ getComponentGhcOptions lbi comp =+ componentGhcOptions silent lbi bi clbi (buildDir lbi)++ where bi = componentBuildInfo comp+ clbi = getComponentLocalBuildInfo lbi (componentName comp)++ getGhcVersion :: LocalBuildInfo -> Maybe Version+ getGhcVersion lbi = let db = withPrograms lbi+ in do ghc <- lookupProgram (simpleProgram "ghc") db+ programVersion ghc++ getSandboxPackageDB :: FilePath -> IO PackageDB+ getSandboxPackageDB sandboxPath = do+ contents <- readFile sandboxPath+ return $ SpecificPackageDB $ extractValue . parse $ contents+ where+ pkgDbKey = "package-db:"+ parse = head . filter (pkgDbKey `isPrefixOf`) . lines+ extractValue = fst . break isSpace . dropWhile isSpace . drop (length pkgDbKey)+++findCabalFile :: FilePath -> IO (Maybe FilePath)+findCabalFile dir = do+ allFiles <- getDirectoryContents dir+ let mbCabalFile = find (isCabalFile) allFiles+ case mbCabalFile of+ Just cabalFile -> return $ Just $ dir </> cabalFile+ Nothing ->+ let parentDir = takeDirectory dir+ in if parentDir == dir+ then return Nothing+ else findCabalFile parentDir++ where++ isCabalFile :: FilePath -> Bool+ isCabalFile path = cabalExtension `isSuffixOf` path+ && length path > length cabalExtension+ where cabalExtension = ".cabal"++# else++getPackageGhcOpts :: FilePath -> IO (Either String [String])+getPackageGhcOpts _ = return $ Right []++findCabalFile :: FilePath -> IO (Maybe FilePath)+findCabalFile _ = return Nothing++#endif
src/Client.hs view
@@ -13,7 +13,7 @@ import Daemonize (daemonize) import Server (createListenSocket, startServer)-import Types (ClientDirective(..), Command(..), ServerDirective(..))+import Types (ClientDirective(..), Command(..), CommandExtra(..), ServerDirective(..)) import Util (readMaybe) connect :: FilePath -> IO Handle@@ -34,18 +34,18 @@ hFlush h startClientReadLoop h -serverCommand :: FilePath -> Command -> [String] -> IO ()-serverCommand sock cmd ghcOpts = do+serverCommand :: FilePath -> Command -> CommandExtra -> IO ()+serverCommand sock cmd cmdExtra = do r <- tryJust (guard . isDoesNotExistError) (connect sock) case r of Right h -> do- hPutStrLn h $ show (SrvCommand cmd ghcOpts)+ hPutStrLn h $ show (SrvCommand cmd cmdExtra) hFlush h startClientReadLoop h Left _ -> do s <- createListenSocket sock daemonize False $ startServer sock (Just s)- serverCommand sock cmd ghcOpts+ serverCommand sock cmd cmdExtra startClientReadLoop :: Handle -> IO () startClientReadLoop h = do
src/CommandArgs.hs view
@@ -24,11 +24,22 @@ "unknown-version (not built with cabal)" #endif +cabalVersion :: String+cabalVersion =+#ifdef ENABLE_CABAL+ "cabal-" ++ VERSION_Cabal+#else+ "no cabal support"+#endif+ fullVersion :: String fullVersion = concat [ programVersion- , " (ghc-", Config.cProjectVersion, "-", arch, "-", os, ")"+ , " ("+ , "ghc-", Config.cProjectVersion, "-", arch, "-", os+ , ", ", cabalVersion+ , ")" ] data HDevTools
src/CommandLoop.hs view
@@ -1,24 +1,31 @@ {-# LANGUAGE CPP #-} module CommandLoop ( newCommandLoopState+ , Config(..)+ , CabalConfig(..)+ , newConfig , startCommandLoop ) where import Control.Monad (when) import Data.IORef import Data.List (find)+import Data.Traversable (traverse) import MonadUtils (MonadIO, liftIO)+import System.Directory (setCurrentDirectory) import System.Exit (ExitCode(ExitFailure, ExitSuccess))+import System.FilePath (takeDirectory) import qualified ErrUtils import qualified Exception (ExceptionMonad) import qualified GHC import qualified GHC.Paths import qualified Outputable+import System.Posix.Types (EpochTime)+import System.Posix.Files (getFileStatus, modificationTime) -import Types (ClientDirective(..), Command(..))+import Types (ClientDirective(..), Command(..), CommandExtra(..)) import Info (getIdentifierInfo, getType)--type CommandObj = (Command, [String])+import Cabal (getPackageGhcOpts) type ClientSend = ClientDirective -> IO () @@ -32,6 +39,35 @@ { stateWarningsEnabled = True } +data CabalConfig = CabalConfig+ { cabalConfigPath :: FilePath+ , cabalConfigLastUpdatedAt :: EpochTime+ }+ deriving Eq++mkCabalConfig :: FilePath -> IO CabalConfig+mkCabalConfig path = do+ fileStatus <- getFileStatus path+ return $ CabalConfig { cabalConfigPath = path+ , cabalConfigLastUpdatedAt = modificationTime fileStatus+ }++data Config = Config+ { configGhcOpts :: [String]+ , configCabal :: Maybe CabalConfig+ }+ deriving Eq++newConfig :: CommandExtra -> IO Config+newConfig cmdExtra = do+ mbCabalConfig <- traverse mkCabalConfig $ ceCabalConfig cmdExtra+ return $ Config { configGhcOpts = ceGhcOptions cmdExtra+ , configCabal = mbCabalConfig+ }+++type CommandObj = (Command, Config)+ withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a withWarnings state warningsValue action = do beforeState <- liftIO $ getWarnings@@ -44,22 +80,26 @@ 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+startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> Config -> Maybe Command -> IO ()+startCommandLoop state clientSend getNextCommand initialConfig mbInitialCommand = 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 state clientSend cmd)- processNextCommand False- else processNextCommand True+ configResult <- configSession state clientSend initialConfig+ case configResult of+ Left e -> do+ liftIO $ mapM_ clientSend+ [ ClientStderr e+ , ClientExit (ExitFailure 1)+ ]+ processNextCommand True+ Right _ -> do+ doMaybe mbInitialCommand $ \cmd -> sendErrors (runCommand state clientSend cmd)+ processNextCommand False case continue of Nothing -> -- Exit return ()- Just (cmd, ghcOpts) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just cmd)+ Just (cmd, config) -> startCommandLoop state clientSend getNextCommand config (Just cmd) where processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) processNextCommand forceReconfig = do@@ -68,37 +108,54 @@ Nothing -> -- Exit return Nothing- Just (cmd, ghcOpts) ->- if forceReconfig || (ghcOpts /= initialGhcOpts)- then return (Just (cmd, ghcOpts))+ Just (cmd, config) ->+ if forceReconfig || (config /= initialConfig)+ then return (Just (cmd, config)) else sendErrors (runCommand state clientSend cmd) >> processNextCommand False sendErrors :: GHC.Ghc () -> GHC.Ghc ()- sendErrors action = GHC.gcatch action (\x -> handleConfigError x >> return ())-- handleConfigError :: GHC.GhcException -> GHC.Ghc Bool- handleConfigError e = do+ sendErrors action = GHC.gcatch action $ \e -> do liftIO $ mapM_ clientSend- [ ClientStderr (GHC.showGhcException e "")+ [ ClientStderr $ GHC.showGhcException e "" , ClientExit (ExitFailure 1) ]- return False+ return () doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () doMaybe Nothing _ = return () doMaybe (Just x) f = f x -configSession :: IORef State -> ClientSend -> [String] -> GHC.Ghc ()-configSession state clientSend ghcOpts = do- initialDynFlags <- GHC.getSessionDynFlags- let updatedDynFlags = initialDynFlags- { GHC.log_action = logAction state clientSend- , GHC.ghcLink = GHC.NoLink- , GHC.hscTarget = GHC.HscInterpreted- }- (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts)- _ <- GHC.setSessionDynFlags finalDynFlags- return ()+configSession :: IORef State -> ClientSend -> Config -> GHC.Ghc (Either String ())+configSession state clientSend config = do+ eCabalGhcOpts <- case configCabal config of+ Nothing ->+ return $ Right []+ Just cabalConfig -> do+ liftIO $ setCurrentDirectory . takeDirectory $ cabalConfigPath cabalConfig+ liftIO $ getPackageGhcOpts $ cabalConfigPath cabalConfig++ case eCabalGhcOpts of+ Left e -> return $ Left e+ Right cabalGhcOpts -> do+ let allGhcOpts = cabalGhcOpts ++ (configGhcOpts config)+ GHC.gcatch (fmap Right $ updateDynFlags allGhcOpts)+ (fmap Left . handleGhcError)+ where+ updateDynFlags :: [String] -> GHC.Ghc ()+ updateDynFlags ghcOpts = do+ initialDynFlags <- GHC.getSessionDynFlags+ let updatedDynFlags = initialDynFlags+ { GHC.log_action = logAction state clientSend+ , GHC.ghcLink = GHC.NoLink+ , GHC.hscTarget = GHC.HscInterpreted+ }+ (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts)+ _ <- GHC.setSessionDynFlags finalDynFlags+ return ()++ handleGhcError :: GHC.GhcException -> GHC.Ghc String+ handleGhcError e = return $ GHC.showGhcException e ""+ runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc () runCommand _ clientSend (CmdCheck file) = do
src/Info.hs view
@@ -16,6 +16,9 @@ #if __GLASGOW_HASKELL__ >= 706 import qualified DynFlags #endif+#if __GLASGOW_HASKELL__ >= 708+import qualified HsExpr+#endif import qualified GHC import qualified HscTypes import qualified NameSet@@ -127,13 +130,22 @@ getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))+#if __GLASGOW_HASKELL__ >= 708+getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = HsExpr.MG _ _ typ _}) = return $ Just (spn, typ)+#else getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ)+#endif getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLHsExpr tcm e = do hs_env <- GHC.getSession+#if __GLASGOW_HASKELL__ >= 708+ let fm_inst_env = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcm+ (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e+#else (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e+#endif return () case mbe of Nothing -> return Nothing@@ -161,14 +173,22 @@ pretty :: GHC.Type -> String pretty = #endif+#if __GLASGOW_HASKELL__ >= 708+ Pretty.showDoc Pretty.OneLineMode 0+#else Pretty.showDocWith Pretty.OneLineMode+#endif #if __GLASGOW_HASKELL__ >= 706 . Outputable.withPprStyleDoc dflags #else . Outputable.withPprStyleDoc #endif (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay)+#if __GLASGOW_HASKELL__ >= 708+ . PprTyThing.pprTypeForUser+#else . PprTyThing.pprTypeForUser False+#endif ------------------------------------------------------------------------------ -- The following was taken from 'ghc-syb-utils'@@ -198,8 +218,13 @@ infoThing :: String -> GHC.Ghc String infoThing str = do names <- GHC.parseName str+#if __GLASGOW_HASKELL__ >= 708+ mb_stuffs <- mapM (GHC.getInfo False) names+ let filtered = filterOutChildren (\(t,_f,_i,_) -> t) (catMaybes mb_stuffs)+#else mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)+#endif unqual <- GHC.getPrintUnqual #if __GLASGOW_HASKELL__ >= 706 dflags <- DynFlags.getDynFlags@@ -207,7 +232,11 @@ #else return $ Outputable.showSDocForUser unqual $ #endif+#if __GLASGOW_HASKELL__ >= 708+ Outputable.vcat (intersperse (Outputable.text "") $ map pprInfo filtered)+#else Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered)+#endif -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data@@ -225,13 +254,19 @@ Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False -#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ >= 708+pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst]) -> Outputable.SDoc+pprInfo (thing, fixity, insts, _) =+ PprTyThing.pprTyThingInContextLoc thing+#elif __GLASGOW_HASKELL__ >= 706 pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc+pprInfo pefas (thing, fixity, insts) =+ PprTyThing.pprTyThingInContextLoc pefas thing #else pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc-#endif pprInfo pefas (thing, fixity, insts) = PprTyThing.pprTyThingInContextLoc pefas thing+#endif Outputable.$$ show_fixity fixity Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) where
src/Main.hs view
@@ -1,34 +1,59 @@ module Main where +import Data.Maybe (fromMaybe)+import Data.Traversable (Traversable(..))+import System.Directory (getCurrentDirectory) import System.Environment (getProgName) import System.IO (hPutStrLn, stderr)+import System.FilePath ((</>), isAbsolute, takeDirectory) +import Cabal (findCabalFile) import Client (getServerStatus, serverCommand, stopServer) import CommandArgs import Daemonize (daemonize) import Server (startServer, createListenSocket)-import Types (Command(..))+import Types (Command(..), CommandExtra(..), emptyCommandExtra) -defaultSocketFilename :: FilePath-defaultSocketFilename = ".hdevtools.sock"+absoluteFilePath :: FilePath -> IO FilePath+absoluteFilePath path = if isAbsolute path then return path else do+ dir <- getCurrentDirectory+ return $ dir </> path -getSocketFilename :: Maybe FilePath -> FilePath-getSocketFilename Nothing = defaultSocketFilename-getSocketFilename (Just f) = f +defaultSocketFile :: FilePath+defaultSocketFile = ".hdevtools.sock"+++fileArg :: HDevTools -> Maybe String+fileArg (Admin {}) = Nothing+fileArg (ModuleFile {}) = Nothing+fileArg args@(Check {}) = Just $ file args+fileArg args@(Info {}) = Just $ file args+fileArg args@(Type {}) = Just $ file args++ main :: IO () main = do args <- loadHDevTools- let sock = getSocketFilename (socket args)+ dir <- maybe getCurrentDirectory (return . takeDirectory) $ fileArg args+ mCabalFile <- findCabalFile dir >>= traverse absoluteFilePath+ let extra = emptyCommandExtra+ { ceGhcOptions = ghcOpts args+ , ceCabalConfig = mCabalFile+ }++ let defaultSocketPath = maybe "" takeDirectory mCabalFile </> defaultSocketFile+ let sock = fromMaybe defaultSocketPath $ socket args+ case args of- Admin {} -> doAdmin sock args- Check {} -> doCheck sock args- ModuleFile {} -> doModuleFile sock args- Info {} -> doInfo sock args- Type {} -> doType sock args+ Admin {} -> doAdmin sock args extra+ Check {} -> doCheck sock args extra+ ModuleFile {} -> doModuleFile sock args extra+ Info {} -> doInfo sock args extra+ Type {} -> doType sock args extra -doAdmin :: FilePath -> HDevTools -> IO ()-doAdmin sock args+doAdmin :: FilePath -> HDevTools -> CommandExtra -> IO ()+doAdmin sock args _extra | start_server args = if noDaemon args then startServer sock Nothing else do@@ -41,26 +66,29 @@ hPutStrLn stderr "You must provide a command. See:" hPutStrLn stderr $ progName ++ " --help" -doModuleFile :: FilePath -> HDevTools -> IO ()-doModuleFile sock args =- serverCommand sock (CmdModuleFile (module_ args)) (ghcOpts args)+doModuleFile :: FilePath -> HDevTools -> CommandExtra -> IO ()+doModuleFile sock args extra =+ serverCommand sock (CmdModuleFile (module_ args)) extra -doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> IO ()-doFileCommand cmdName cmd sock args+doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> CommandExtra -> IO ()+doFileCommand cmdName cmd sock args extra | null (file args) = do progName <- getProgName hPutStrLn stderr "You must provide a haskell source file. See:" hPutStrLn stderr $ progName ++ " " ++ cmdName ++ " --help"- | otherwise = serverCommand sock (cmd args) (ghcOpts args)+ | otherwise = do+ absFile <- absoluteFilePath $ file args+ let args' = args { file = absFile }+ serverCommand sock (cmd args') extra -doCheck :: FilePath -> HDevTools -> IO ()+doCheck :: FilePath -> HDevTools -> CommandExtra -> IO () doCheck = doFileCommand "check" $ \args -> CmdCheck (file args) -doInfo :: FilePath -> HDevTools -> IO ()+doInfo :: FilePath -> HDevTools -> CommandExtra -> IO () doInfo = doFileCommand "info" $ \args -> CmdInfo (file args) (identifier args) -doType :: FilePath -> HDevTools -> IO ()+doType :: FilePath -> HDevTools -> CommandExtra -> IO () doType = doFileCommand "type" $ \args -> CmdType (file args) (line args, col args)
src/Server.hs view
@@ -1,16 +1,17 @@ module Server where -import Control.Exception (bracket, finally, tryJust)+import Control.Exception (bracket, finally, handleJust, tryJust) import Control.Monad (guard) import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import GHC.IO.Exception (IOErrorType(ResourceVanished)) import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose) import System.Directory (removeFile) import System.Exit (ExitCode(ExitSuccess)) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn)-import System.IO.Error (isDoesNotExistError)+import System.IO.Error (ioeGetErrorType, isDoesNotExistError) -import CommandLoop (newCommandLoopState, startCommandLoop)-import Types (ClientDirective(..), Command, ServerDirective(..))+import CommandLoop (newCommandLoopState, Config, newConfig, startCommandLoop)+import Types (ClientDirective(..), Command, emptyCommandExtra, ServerDirective(..)) import Util (readMaybe) createListenSocket :: FilePath -> IO Socket@@ -32,7 +33,8 @@ go sock = do state <- newCommandLoopState currentClient <- newIORef Nothing- startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing+ config <- newConfig emptyCommandExtra+ startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) config Nothing removeSocketFile :: IO () removeSocketFile = do@@ -44,13 +46,16 @@ clientSend currentClient clientDirective = do mbH <- readIORef currentClient case mbH of- Just h -> do- -- TODO catch exception+ Just h -> ignoreEPipe $ do hPutStrLn h (show clientDirective) hFlush h- Nothing -> error "This is impossible"+ Nothing -> return ()+ where+ -- EPIPE means that the client is no longer there.+ ignoreEPipe = handleJust (guard . isEPipe) (const $ return ())+ isEPipe = (==ResourceVanished) . ioeGetErrorType -getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, [String]))+getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, Config)) getNextCommand currentClient sock = do checkCurrent <- readIORef currentClient case checkCurrent of@@ -65,8 +70,9 @@ clientSend currentClient $ ClientUnexpectedError $ "The client sent an invalid message to the server: " ++ show msg getNextCommand currentClient sock- Just (SrvCommand cmd ghcOpts) -> do- return $ Just (cmd, ghcOpts)+ Just (SrvCommand cmd cmdExtra) -> do+ config <- newConfig cmdExtra+ return $ Just (cmd, config) Just SrvStatus -> do mapM_ (clientSend currentClient) $ [ ClientStdout "Server is running."
src/Types.hs view
@@ -2,12 +2,24 @@ ( ServerDirective(..) , ClientDirective(..) , Command(..)+ , CommandExtra(..)+ , emptyCommandExtra ) where import System.Exit (ExitCode) +data CommandExtra = CommandExtra+ { ceGhcOptions :: [String]+ , ceCabalConfig :: Maybe FilePath+ } deriving (Read, Show)++emptyCommandExtra :: CommandExtra+emptyCommandExtra = CommandExtra { ceGhcOptions = []+ , ceCabalConfig = Nothing+ }+ data ServerDirective- = SrvCommand Command [String]+ = SrvCommand Command CommandExtra | SrvStatus | SrvExit deriving (Read, Show)
− test_all_hsenv.sh
@@ -1,2 +0,0 @@-#!/bin/sh-./test_hsenv.sh `echo .hsenv_* | sed -e 's/.hsenv_//g'`
− test_hsenv.sh
@@ -1,22 +0,0 @@-#!/bin/bash--set -e--if [ $# -lt 1 ]-then- echo "Usage:"- echo "$0 <hsenv_name> [<hsenv_name2> ...]"- exit 2-fi--for i in $*-do- source .hsenv_$i/bin/activate- cabal build- export HDEVTOOLS=./dist_$i/build/hdevtools/hdevtools- ./tests/test_runner.sh- deactivate_hsenv-done--echo-echo 'All Tests Passed in:' $*
− tests/Child.hs
@@ -1,6 +0,0 @@-module Child where--import Parent--child :: String-child = "child of " ++ parent
− tests/Parent.hs
@@ -1,4 +0,0 @@-module Parent where--parent :: String-parent = "parent"
− tests/SampleError.hs
@@ -1,9 +0,0 @@--- Sample Module used for testing---- This module should cause a compilation error:------ Sample2.hs:9:1: parse error (possibly incorrect indentation)--module SampleError where--a = foo
− tests/Simple.hs
@@ -1,7 +0,0 @@--- Sample Module used for testing---- This module contains no errors or warnings-module Sample1 where--increment :: Int -> Int-increment x = x + 1
− tests/test_module_file.sh
@@ -1,13 +0,0 @@-#!/bin/sh--set -e--SOCK=`mktemp -u`--$HDEVTOOLS check --socket=$SOCK Child.hs--PARENT=`$HDEVTOOLS modulefile --socket=$SOCK Parent`--[ "$PARENT" = "./Parent.hs" ]--$HDEVTOOLS --socket=$SOCK --stop-server
− tests/test_runner.sh
@@ -1,59 +0,0 @@-#!/bin/sh--set -e--ALL_TESTS="\- test_start_stop.sh \- test_simple_check.sh \- test_sample_error.sh \- test_module_file.sh \- "--if [ ! $HDEVTOOLS ]-then- echo 'You must set the HDEVTOOLS environment variable to the path of the hdevtools binary'- exit 1-fi--case "$HDEVTOOLS" in- */*)- # Convert relative path to absolute:- export HDEVTOOLS=`pwd`/$HDEVTOOLS-esac--echo $HDEVTOOLS--if [ $# -ne 0 ]-then- TESTS=$*-else- TESTS=$ALL_TESTS- echo 'Running All Tests'-fi--echo '------------------------------------------------------------------------'--cd `dirname $0`--ERRORS=0-for i in $TESTS-do- echo $i- echo- if sh $i- then- echo 'Test OK'- else- echo 'Test FAILED'- ERRORS=`expr $ERRORS + 1`- fi- echo '------------------------------------------------------------------------'-done--if [ $ERRORS = 0 ]-then- echo 'All Tests OK'-else- echo $ERRORS 'FAILED Tests'-fi-exit $ERRORS
− tests/test_sample_error.sh
@@ -1,16 +0,0 @@-#!/bin/sh--set -e--SOCK=`mktemp -u`--EXPECTED_ERRORS='SampleError.hs:9:5: Not in scope: `foo'\'''--if ERRORS=`$HDEVTOOLS check --socket=$SOCK SampleError.hs`-then- false-elsh- [ "$ERRORS" = "$EXPECTED_ERRORS" ]-fi--$HDEVTOOLS --socket=$SOCK --stop-server
− tests/test_simple_check.sh
@@ -1,11 +0,0 @@-#!/bin/sh--set -e--SOCK=`mktemp -u`--ERRORS=`$HDEVTOOLS check --socket=$SOCK Simple.hs`--[ -z "$ERRORS" ]--$HDEVTOOLS --socket=$SOCK --stop-server
− tests/test_start_stop.sh
@@ -1,20 +0,0 @@-#!/bin/sh--set -e--SOCK=`mktemp -u`--echo '> Starting the server'-$HDEVTOOLS --socket=$SOCK --start-server--echo '> Checking status'-$HDEVTOOLS --socket=$SOCK --status--echo '> Checking that the socket file exists'-if [ ! -S $SOCK ]; then false; fi--echo '> Stopping the server'-$HDEVTOOLS --socket=$SOCK --stop-server--echo '> Checking that the socket file no longer exists'-if [ -e $SOCK ]; then false; fi