├── AUTHORS ├── LICENSE ├── README.md ├── Setup.hs ├── hdevtools.cabal ├── src ├── Cabal.hs ├── Client.hs ├── CommandArgs.hs ├── CommandLoop.hs ├── Daemonize.hs ├── FindSymbol.hs ├── Info.hs ├── Main.hs ├── Server.hs ├── Stack.hs ├── Types.hs └── Util.hs ├── stack.yaml ├── test_all_hsenv.sh ├── test_hsenv.sh └── tests ├── Child.hs ├── Parent.hs ├── SampleError.hs ├── Simple.hs ├── test_module_file.sh ├── test_runner.sh ├── test_sample_error.sh ├── test_simple_check.sh └── test_start_stop.sh /AUTHORS: -------------------------------------------------------------------------------- 1 | Bit Connor 2 | Takano Akio 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2012 The hdevtools Authors (see AUTHORS file) 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hdevtools 2 | ========= 3 | This project is active at https://github.com/hdevtools/hdevtools. Please visit 4 | that repo! 5 | 6 | Persistent GHC powered background server for FAST Haskell development tools 7 | 8 | 9 | About 10 | ----- 11 | 12 | `hdevtools` is a backend for text editor plugins, to allow for things such as 13 | syntax and type checking of Haskell code, and retrieving type information, all 14 | directly from within your text editor. 15 | 16 | The advantage that `hdevtools` has over competitors, is that it runs silently 17 | in a persistent background process, and therefore is able to keeps all of your 18 | Haskell modules and dependent libraries loaded in memory. This way, when you 19 | change only a single source file, only it needs to be reloaded and rechecked, 20 | instead of having to reload everything. 21 | 22 | This makes `hdevtools` very fast for checking syntax and type errors (runs just 23 | as fast as the `:reload` command in GHCi). 24 | 25 | In fact, syntax and type checking is so fast, that you can safely enable auto 26 | checking on every save. Even for huge projects, checking is nearly instant. 27 | 28 | Once you start using `hdevtools` and you get used to having your errors shown 29 | to you instantly (without having to switch back and forth between GHCi and your 30 | editor), and shown directly on your code, in your editor (without having to 31 | wait forever for GHC to run) you will wonder how you ever lived without it. 32 | 33 | In addition to checking Haskell source code for errors, `hdevtools` has tools 34 | for getting info about identifiers, and getting type information for snippets 35 | of code. 36 | 37 | Text Editor Integration 38 | ----------------------- 39 | 40 | `hdevtools` is designed to be integrated into text editors. The list of current 41 | editor plugins that supply this integration is below. 42 | 43 | But before you do anything, you must first install `hdevtools` itself. The 44 | easiest way is from [Hackage][1] via cabal install: 45 | 46 | $ cabal install hdevtools 47 | 48 | Then you should install one or more of the following editor plugins: 49 | 50 | ### Vim - [Syntastic][2] ### 51 | 52 | [Syntastic][2] is a popular syntax checking plugin for Vim, and is the 53 | recommended Vim integration of `hdevtools` syntax and type checking. Recent 54 | versions of Syntastic(since Sep. 2012) have builtin support for `hdevtools`. 55 | 56 | Simply install `hdevtools` (as above) and [Syntastic][2], and it will 57 | automatically check your Haskell files. 58 | 59 | [Syntastic][2] will respect the `g:hdevtools_options` variable (the same one as 60 | used by [vim-hdevtools][3], see below). See the section "Specifying GHC 61 | Options" below for details how to use it. 62 | 63 | ### Vim - [vim-hdevtools][3] ### 64 | 65 | In addition to Syntastic, it is recommended that you also use 66 | [`vim-hdevtools`][3] for additional functionality. 67 | 68 | [`vim-hdevtools`][3] offers integration with the rest of the `hdevtools` tools, 69 | including retrieving info about the identifier under the cursor, and getting 70 | the type of the code under the cursor. Refer to its documentation for more 71 | details. 72 | 73 | ### Emacs - [flycheck][5] ### 74 | 75 | [Flycheck][5] is a modern batteries-included 76 | syntax checker for Emacs, and there is a [flycheck-hdevtools][6] checker available. 77 | 78 | 79 | ### Atom - [linter][8] ### 80 | 81 | There are *two* packages for the [Atom](https://atom.io) editor: 82 | 83 | + [linter-hdevtools][8] quickly finds and underlines type errors in Haskell files, 84 | + [hover-tooltips-hdevtools][9] displays the types of identifiers under the mouse. 85 | 86 | ### Manual Editor Integration for any Editor ### 87 | 88 | Most editors allow you to run a `make` command, and will then parse the output 89 | for errors and show line numbers, allowing you to jump between errors. 90 | 91 | The `hdevtools check` command is suitable for such usage. 92 | 93 | For example, in Vim something like this will work: 94 | 95 | :let &makeprg='hdevtools check %' 96 | 97 | (Vim will replace the `%` character with the name of the current file). Then 98 | you can run 99 | 100 | :make 101 | 102 | And Vim will invoke `hdevtools` to check the current file for errors, and then 103 | show a list of them and allow jumping to them. 104 | 105 | See the "Command Line Usage" section below for more information. 106 | 107 | Command Line Usage 108 | ------------------ 109 | 110 | Note: When using one of the above editor plugins, you don't really need to know 111 | this. 112 | 113 | ### Available Commands and Help ### 114 | 115 | For the list of commands available, run: 116 | 117 | $ hdevtools --help 118 | 119 | To get help for a specific command, run: 120 | 121 | $ hdevtools [COMMAND] --help 122 | 123 | For example: 124 | 125 | $ hdevtools check --help 126 | 127 | ### The `hdevtools` background process ### 128 | 129 | The first time `hdevtools` runs a command, it will spawn a background process 130 | that will remain running forever. You can check the status of this background 131 | process by running: 132 | 133 | $ hdevtools --status 134 | 135 | You can shutdown the background process by running: 136 | 137 | $ hdevtools --stop-server 138 | 139 | Communication with the background process is done through a unix socket file. 140 | The default name is `.hdevtools.sock`, in the current directory. This allows 141 | you to use `hdevtools` with multiple projects simultaneously, without the 142 | background processes getting in the way of each other. 143 | 144 | You can use a different socket file name with the `--socket` option, which 145 | should be used for each invocation of `hdevtools`. Remember that when telling 146 | `hdevtools` to check a Haskell file, paths are relative to the path of the 147 | background process, not your current directory. This can cause problems, and 148 | therefore it is recommended that you leave the socket file as the default, and 149 | always run `hdevtools` from the same directory. 150 | 151 | You can specify the path to a target file with the `--path` option. This is 152 | useful for integration with IDEs that submit a *copy* of the original source 153 | file (in a temporary directory) to `hdevtools` making it impossible to extract 154 | the `.cabal` information for the file's project. In such cases, you can run as: 155 | 156 | $ hdevtools check -p /path/to/file.hs /tmp/file.hs 157 | 158 | and `hdevtools` will use the given path to obtain the `.cabal` information. 159 | 160 | 161 | ### Specifying GHC Options ### 162 | 163 | For most non-trivial projects, you will need to tell `hdevtools` about 164 | additional GHC options that your project requires. 165 | 166 | All `hdevtools` commands accept a `-g` flag for this purpose. 167 | 168 | For example: 169 | 170 | * Your project source code is in the directory `src` 171 | * You want to use the GHC option `-Wall` 172 | * You want to hide the package `transformers` to prevent conflicts 173 | 174 | Invoke `hdevtools` with something like this: 175 | 176 | $ hdevtools check -g -isrc -g -Wall -g -hide-package -g transformers Foo.hs 177 | 178 | Notice that a `-g` flag is inserted before each GHC option. Don't try to string 179 | multiple GHC options together after a single `-g` flag: 180 | 181 | This won't work: 182 | 183 | $ hdevtools check -g '-hide-package transformers' Foo.hs 184 | 185 | The Vim plugins allow setting GHC options in the `g:hdevtools_options` 186 | variable. For example, for the above project, put the following in your 187 | `.vimrc`: 188 | 189 | let g:hdevtools_options = '-g -isrc -g -Wall -g -hide-package -g transformers' 190 | 191 | In general, you will need to pass to `hdevtools` the same GHC options that you 192 | would pass to GHCi. 193 | 194 | Credits 195 | ------- 196 | 197 | `hdevtools` was inspired by [ghcmod][4]. 198 | 199 | [1]: http://hackage.haskell.org/package/hdevtools 200 | [2]: https://github.com/scrooloose/syntastic 201 | [3]: https://github.com/bitc/vim-hdevtools 202 | [4]: http://www.mew.org/~kazu/proj/ghc-mod/en/ 203 | [5]: https://github.com/flycheck/flycheck 204 | [6]: https://github.com/flycheck/flycheck-hdevtools 205 | [7]: https://atom.io 206 | [8]: https://atom.io/packages/linter-hdevtools 207 | [9]: https://atom.io/packages/hover-tooltips-hdevtools 208 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hdevtools.cabal: -------------------------------------------------------------------------------- 1 | name: hdevtools 2 | version: 0.1.2.1 3 | synopsis: Persistent GHC powered background server for FAST haskell development tools 4 | description: 5 | 'hdevtools' is a backend for text editor plugins, to allow for things such as 6 | syntax and type checking of Haskell code, and retrieving type information, all 7 | directly from within your text editor. 8 | . 9 | The advantage that 'hdevtools' has over competitors, is that it runs silently 10 | in a persistent background process, and therefore is able to keeps all of your 11 | Haskell modules and dependent libraries loaded in memory. This way, when you 12 | change only a single source file, only it needs to be reloaded and rechecked, 13 | instead of having to reload everything. 14 | . 15 | This makes 'hdevtools' very fast for checking syntax and type errors (runs just 16 | as fast as the ':reload' command in GHCi). 17 | . 18 | In fact, syntax and type checking is so fast, that you can safely enable auto 19 | checking on every save. Even for huge projects, checking is nearly instant. 20 | . 21 | Once you start using 'hdevtools' and you get used to having your errors shown 22 | to you instantly (without having to switch back and forth between GHCi and your 23 | editor), and shown directly on your code, in your editor (without having to 24 | wait forever for GHC to run) you will wonder how you ever lived without it. 25 | . 26 | In addition to checking Haskell source code for errors, 'hdevtools' has tools 27 | for getting info about identifiers, and getting type information for snippets 28 | of code. 29 | 30 | license: MIT 31 | license-file: LICENSE 32 | author: Bit Connor 33 | maintainer: schell.scivally@synapsegroup.com 34 | copyright: See AUTHORS file 35 | category: Development 36 | homepage: https://github.com/schell/hdevtools/ 37 | bug-reports: https://github.com/schell/hdevtools/issues/ 38 | build-type: Simple 39 | cabal-version: >=1.8 40 | 41 | source-repository head 42 | type: git 43 | location: git://github.com/schell/hdevtools.git 44 | 45 | executable hdevtools 46 | hs-source-dirs: src 47 | ghc-options: -Wall 48 | cpp-options: -DCABAL 49 | main-is: Main.hs 50 | other-modules: Cabal, 51 | Client, 52 | CommandArgs, 53 | CommandLoop, 54 | Daemonize, 55 | FindSymbol, 56 | Info, 57 | Main, 58 | Server, 59 | Stack, 60 | Types, 61 | Util, 62 | Paths_hdevtools 63 | 64 | build-depends: base == 4.*, 65 | cmdargs, 66 | directory, 67 | filepath, 68 | ghc >= 7.2, 69 | ghc-paths, 70 | syb, 71 | network, 72 | process, 73 | time, 74 | transformers, 75 | unix 76 | 77 | if impl(ghc == 7.6.*) 78 | build-depends: Cabal == 1.16.* 79 | cpp-options: -DENABLE_CABAL 80 | 81 | if impl(ghc >= 7.7) 82 | build-depends: Cabal >= 1.18 83 | cpp-options: -DENABLE_CABAL 84 | 85 | if impl(ghc >= 7.9) 86 | build-depends: Cabal >= 1.22, 87 | bin-package-db 88 | 89 | cpp-options: -DENABLE_CABAL 90 | -------------------------------------------------------------------------------- /src/Cabal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Cabal 3 | ( getPackageGhcOpts 4 | , findCabalFile 5 | ) where 6 | 7 | #ifdef ENABLE_CABAL 8 | import Stack 9 | import Control.Exception (IOException, catch) 10 | import Control.Monad (when) 11 | import Control.Monad.Trans.Class (lift) 12 | import Control.Monad.Trans.State (execStateT, modify) 13 | import Data.Char (isSpace) 14 | import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf) 15 | #if __GLASGOW_HASKELL__ < 709 16 | import Control.Applicative ((<$>)) 17 | import Data.Monoid (Monoid(..)) 18 | #endif 19 | import Distribution.Package (PackageIdentifier(..), PackageName) 20 | import Distribution.PackageDescription (PackageDescription(..), Executable(..), TestSuite(..), Benchmark(..), emptyHookedBuildInfo, buildable, libBuildInfo) 21 | import Distribution.PackageDescription.Parse (readPackageDescription) 22 | import Distribution.Simple.Configure (configure) 23 | import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), ComponentLocalBuildInfo(..), 24 | Component(..), ComponentName(..), 25 | #if __GLASGOW_HASKELL__ < 707 26 | allComponentsBy, 27 | #endif 28 | componentBuildInfo, foldComponent) 29 | import Distribution.Simple.Compiler (PackageDB(..)) 30 | import Distribution.Simple.Command (CommandParse(..), commandParseArgs) 31 | import Distribution.Simple.GHC (componentGhcOptions) 32 | import Distribution.Simple.Program (defaultProgramConfiguration) 33 | import Distribution.Simple.Program.Db (lookupProgram) 34 | import Distribution.Simple.Program.Types (ConfiguredProgram(programVersion), simpleProgram) 35 | import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions) 36 | import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, configureCommand, toFlag) 37 | #if __GLASGOW_HASKELL__ >= 709 38 | import Distribution.Utils.NubList 39 | import qualified Distribution.Simple.GHC as GHC(configure) 40 | #endif 41 | import Distribution.Verbosity (silent) 42 | import Distribution.Version (Version(..)) 43 | 44 | import System.IO.Error (ioeGetErrorString) 45 | import System.Directory (doesFileExist, getDirectoryContents) 46 | import System.FilePath (takeDirectory, splitFileName, ()) 47 | 48 | 49 | componentName :: Component -> ComponentName 50 | componentName = 51 | foldComponent (const CLibName) 52 | (CExeName . exeName) 53 | (CTestName . testName) 54 | (CBenchName . benchmarkName) 55 | 56 | getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo 57 | #if __GLASGOW_HASKELL__ >= 707 58 | getComponentLocalBuildInfo lbi cname = getLocalBuildInfo cname $ componentsConfigs lbi 59 | where getLocalBuildInfo cname' ((cname'', clbi, _):cfgs) = 60 | if cname' == cname'' then clbi else getLocalBuildInfo cname' cfgs 61 | getLocalBuildInfo _ [] = error $ "internal error: missing config" 62 | #else 63 | getComponentLocalBuildInfo lbi CLibName = 64 | case libraryConfig lbi of 65 | Nothing -> error $ "internal error: missing library config" 66 | Just clbi -> clbi 67 | getComponentLocalBuildInfo lbi (CExeName name) = 68 | case lookup name (executableConfigs lbi) of 69 | Nothing -> error $ "internal error: missing config for executable " ++ name 70 | Just clbi -> clbi 71 | getComponentLocalBuildInfo lbi (CTestName name) = 72 | case lookup name (testSuiteConfigs lbi) of 73 | Nothing -> error $ "internal error: missing config for test suite " ++ name 74 | Just clbi -> clbi 75 | getComponentLocalBuildInfo lbi (CBenchName name) = 76 | case lookup name (testSuiteConfigs lbi) of 77 | Nothing -> error $ "internal error: missing config for benchmark " ++ name 78 | Just clbi -> clbi 79 | #endif 80 | 81 | #if __GLASGOW_HASKELL__ >= 707 82 | -- TODO: Fix callsites so we don't need `allComponentsBy`. It was taken from 83 | -- http://hackage.haskell.org/package/Cabal-1.16.0.3/docs/src/Distribution-Simple-LocalBuildInfo.html#allComponentsBy 84 | -- since it doesn't exist in Cabal 1.18.* 85 | -- 86 | -- | Obtains all components (libs, exes, or test suites), transformed by the 87 | -- given function. Useful for gathering dependencies with component context. 88 | allComponentsBy :: PackageDescription 89 | -> (Component -> a) 90 | -> [a] 91 | allComponentsBy pkg_descr f = 92 | [ f (CLib lib) | Just lib <- [library pkg_descr] 93 | , buildable (libBuildInfo lib) ] 94 | ++ [ f (CExe exe) | exe <- executables pkg_descr 95 | , buildable (buildInfo exe) ] 96 | ++ [ f (CTest tst) | tst <- testSuites pkg_descr 97 | , buildable (testBuildInfo tst) 98 | , testEnabled tst ] 99 | ++ [ f (CBench bm) | bm <- benchmarks pkg_descr 100 | , buildable (benchmarkBuildInfo bm) 101 | , benchmarkEnabled bm ] 102 | #endif 103 | 104 | stackifyFlags :: ConfigFlags -> Maybe StackConfig -> ConfigFlags 105 | stackifyFlags cfg Nothing = cfg 106 | stackifyFlags cfg (Just si) = cfg { configDistPref = toFlag dist 107 | , configPackageDBs = pdbs 108 | } 109 | where 110 | pdbs = [Nothing, Just GlobalPackageDB] ++ pdbs' 111 | pdbs' = Just . SpecificPackageDB <$> stackDbs si 112 | dist = stackDist si 113 | 114 | -- via: https://groups.google.com/d/msg/haskell-stack/8HJ6DHAinU0/J68U6AXTsasJ 115 | -- cabal configure --package-db=clear --package-db=global --package-db=$(stack path --snapshot-pkg-db) --package-db=$(stack path --local-pkg-db) 116 | 117 | getPackageGhcOpts :: FilePath -> Maybe StackConfig -> [String] -> IO (Either String [String]) 118 | getPackageGhcOpts path mbStack opts = do 119 | getPackageGhcOpts' `catch` (\e -> do 120 | return $ Left $ "Cabal error: " ++ (ioeGetErrorString (e :: IOException))) 121 | where 122 | getPackageGhcOpts' :: IO (Either String [String]) 123 | getPackageGhcOpts' = do 124 | genPkgDescr <- readPackageDescription silent path 125 | distDir <- getDistDir 126 | 127 | let programCfg = defaultProgramConfiguration 128 | let initCfgFlags = (defaultConfigFlags programCfg) 129 | { configDistPref = toFlag distDir 130 | -- TODO: figure out how to find out this flag 131 | , configUserInstall = toFlag True 132 | 133 | -- configure with --enable-tests to include test dependencies/modules 134 | , configTests = toFlag True 135 | 136 | -- configure with --enable-benchmarks to include benchmark dependencies/modules 137 | , configBenchmarks = toFlag True 138 | } 139 | let initCfgFlags' = stackifyFlags initCfgFlags mbStack 140 | 141 | cfgFlags <- flip execStateT initCfgFlags' $ do 142 | let sandboxConfig = takeDirectory path "cabal.sandbox.config" 143 | 144 | exists <- lift $ doesFileExist sandboxConfig 145 | when (exists) $ do 146 | sandboxPackageDb <- lift $ getSandboxPackageDB sandboxConfig 147 | modify $ \x -> x { configPackageDBs = [Just sandboxPackageDb] } 148 | 149 | let cmdUI = configureCommand programCfg 150 | case commandParseArgs cmdUI True opts of 151 | CommandReadyToGo (modFlags, _) -> modify modFlags 152 | CommandErrors (e:_) -> error e 153 | _ -> return () 154 | 155 | localBuildInfo <- configure (genPkgDescr, emptyHookedBuildInfo) cfgFlags 156 | let pkgDescr = localPkgDescr localBuildInfo 157 | let baseDir = fst . splitFileName $ path 158 | case getGhcVersion localBuildInfo of 159 | Nothing -> return $ Left "GHC is not configured" 160 | 161 | #if __GLASGOW_HASKELL__ >= 709 162 | Just _ -> do 163 | let mbLibName = pkgLibName pkgDescr 164 | let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo 165 | -- FIX bug in GhcOptions' `mappend` 166 | ghcOpts = ghcOpts' { ghcOptExtra = overNubListR (filter (/= "-Werror")) $ ghcOptExtra ghcOpts' 167 | , ghcOptPackageDBs = sort $ nub (ghcOptPackageDBs ghcOpts') 168 | , ghcOptPackages = overNubListR (filter (\(_, pkgId, _) -> Just (pkgName pkgId) /= mbLibName)) $ (ghcOptPackages ghcOpts') 169 | , ghcOptSourcePath = overNubListR (map (baseDir )) (ghcOptSourcePath ghcOpts') 170 | } 171 | putStrLn "configuring" 172 | (ghcInfo,_,_) <- GHC.configure silent Nothing Nothing defaultProgramConfiguration 173 | 174 | return $ Right $ renderGhcOptions ghcInfo ghcOpts 175 | #else 176 | Just ghcVersion -> do 177 | let mbLibName = pkgLibName pkgDescr 178 | let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo 179 | 180 | ghcOpts = ghcOpts' { ghcOptExtra = filter (/= "-Werror") $ nub $ ghcOptExtra ghcOpts' 181 | , ghcOptPackages = filter (\(_, pkgId) -> Just (pkgName pkgId) /= mbLibName) $ nub (ghcOptPackages ghcOpts') 182 | , ghcOptSourcePath = map (baseDir ) (ghcOptSourcePath ghcOpts') 183 | } 184 | return $ Right $ renderGhcOptions ghcVersion ghcOpts 185 | #endif 186 | 187 | -- returns the right 'dist' directory in the case of a sandbox 188 | getDistDir = do 189 | let dir = takeDirectory path "dist" 190 | contents <- getDirectoryContents dir 191 | return $ case find ("dist-sandbox-" `isPrefixOf`) contents of 192 | Just sbdir -> dir sbdir 193 | Nothing -> dir 194 | 195 | pkgLibName :: PackageDescription -> Maybe PackageName 196 | pkgLibName pkgDescr = if hasLibrary pkgDescr 197 | then Just $ pkgName . package $ pkgDescr 198 | else Nothing 199 | 200 | hasLibrary :: PackageDescription -> Bool 201 | hasLibrary = maybe False (\_ -> True) . library 202 | 203 | getComponentGhcOptions :: LocalBuildInfo -> Component -> GhcOptions 204 | getComponentGhcOptions lbi comp = 205 | componentGhcOptions silent lbi bi clbi (buildDir lbi) 206 | 207 | where bi = componentBuildInfo comp 208 | clbi = getComponentLocalBuildInfo lbi (componentName comp) 209 | 210 | getGhcVersion :: LocalBuildInfo -> Maybe Version 211 | getGhcVersion lbi = let db = withPrograms lbi 212 | in do ghc <- lookupProgram (simpleProgram "ghc") db 213 | programVersion ghc 214 | 215 | getSandboxPackageDB :: FilePath -> IO PackageDB 216 | getSandboxPackageDB sandboxPath = do 217 | contents <- readFile sandboxPath 218 | return $ SpecificPackageDB $ extractValue . parse $ contents 219 | where 220 | pkgDbKey = "package-db:" 221 | parse = head . filter (pkgDbKey `isPrefixOf`) . lines 222 | extractValue = fst . break isSpace . dropWhile isSpace . drop (length pkgDbKey) 223 | 224 | 225 | findCabalFile :: FilePath -> IO (Maybe FilePath) 226 | findCabalFile dir = do 227 | allFiles <- getDirectoryContents dir 228 | let mbCabalFile = find (isCabalFile) allFiles 229 | case mbCabalFile of 230 | Just cabalFile -> return $ Just $ dir cabalFile 231 | Nothing -> 232 | let parentDir = takeDirectory dir 233 | in if parentDir == dir 234 | then return Nothing 235 | else findCabalFile parentDir 236 | 237 | where 238 | 239 | isCabalFile :: FilePath -> Bool 240 | isCabalFile path = cabalExtension `isSuffixOf` path 241 | && length path > length cabalExtension 242 | where cabalExtension = ".cabal" 243 | 244 | # else 245 | 246 | getPackageGhcOpts :: FilePath -> [String] -> IO (Either String [String]) 247 | getPackageGhcOpts _ _ = return $ Right [] 248 | 249 | findCabalFile :: FilePath -> IO (Maybe FilePath) 250 | findCabalFile _ = return Nothing 251 | 252 | #endif 253 | -------------------------------------------------------------------------------- /src/Client.hs: -------------------------------------------------------------------------------- 1 | module Client 2 | ( getServerStatus 3 | , stopServer 4 | , serverCommand 5 | ) where 6 | 7 | import Control.Exception (tryJust) 8 | import Control.Monad (guard) 9 | import Network (PortID(UnixSocket), connectTo) 10 | import System.Exit (exitFailure, exitWith) 11 | import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr) 12 | import System.IO.Error (isDoesNotExistError) 13 | 14 | import Daemonize (daemonize) 15 | import Server (createListenSocket, startServer) 16 | import Types (ClientDirective(..), Command(..), CommandExtra(..), ServerDirective(..)) 17 | import Util (readMaybe) 18 | 19 | connect :: FilePath -> IO Handle 20 | connect sock = do 21 | connectTo "" (UnixSocket sock) 22 | 23 | getServerStatus :: FilePath -> IO () 24 | getServerStatus sock = do 25 | h <- connect sock 26 | hPutStrLn h $ show SrvStatus 27 | hFlush h 28 | startClientReadLoop h 29 | 30 | stopServer :: FilePath -> IO () 31 | stopServer sock = do 32 | h <- connect sock 33 | hPutStrLn h $ show SrvExit 34 | hFlush h 35 | startClientReadLoop h 36 | 37 | serverCommand :: FilePath -> Command -> CommandExtra -> IO () 38 | serverCommand sock cmd cmdExtra = do 39 | r <- tryJust (guard . isDoesNotExistError) (connect sock) 40 | case r of 41 | Right h -> do 42 | hPutStrLn h $ show (SrvCommand cmd cmdExtra) 43 | hFlush h 44 | startClientReadLoop h 45 | Left _ -> do 46 | s <- createListenSocket sock 47 | daemonize False $ startServer sock (Just s) 48 | serverCommand sock cmd cmdExtra 49 | 50 | startClientReadLoop :: Handle -> IO () 51 | startClientReadLoop h = do 52 | msg <- hGetLine h 53 | let clientDirective = readMaybe msg 54 | case clientDirective of 55 | Just (ClientStdout out) -> putStrLn out >> startClientReadLoop h 56 | Just (ClientStderr err) -> hPutStrLn stderr err >> startClientReadLoop h 57 | Just (ClientExit exitCode) -> hClose h >> exitWith exitCode 58 | Just (ClientUnexpectedError err) -> hClose h >> unexpectedError err 59 | Nothing -> do 60 | hClose h 61 | unexpectedError $ 62 | "The server sent an invalid message to the client: " ++ show msg 63 | 64 | unexpectedError :: String -> IO () 65 | unexpectedError err = do 66 | hPutStrLn stderr banner 67 | hPutStrLn stderr err 68 | hPutStrLn stderr banner 69 | exitFailure 70 | where banner = replicate 78 '*' 71 | -------------------------------------------------------------------------------- /src/CommandArgs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE CPP #-} 3 | module CommandArgs 4 | ( HDevTools(..) 5 | , loadHDevTools 6 | ) 7 | where 8 | 9 | import System.Console.CmdArgs.Implicit 10 | import System.Environment (getProgName) 11 | import System.Info (arch, os) 12 | import qualified Config 13 | 14 | #ifdef CABAL 15 | import Data.Version (showVersion) 16 | import Paths_hdevtools (version) 17 | #endif 18 | 19 | programVersion :: String 20 | programVersion = 21 | #ifdef CABAL 22 | "version " ++ showVersion version 23 | #else 24 | "unknown-version (not built with cabal)" 25 | #endif 26 | 27 | cabalVersion :: String 28 | cabalVersion = 29 | #ifdef ENABLE_CABAL 30 | "cabal-" ++ VERSION_Cabal 31 | #else 32 | "no cabal support" 33 | #endif 34 | 35 | fullVersion :: String 36 | fullVersion = 37 | concat 38 | [ programVersion 39 | , " (" 40 | , "ghc-", Config.cProjectVersion, "-", arch, "-", os 41 | , ", ", cabalVersion 42 | , ")" 43 | ] 44 | 45 | data HDevTools 46 | = Admin 47 | { socket :: Maybe FilePath 48 | , start_server :: Bool 49 | , noDaemon :: Bool 50 | , status :: Bool 51 | , stop_server :: Bool 52 | } 53 | | Check 54 | { socket :: Maybe FilePath 55 | , ghcOpts :: [String] 56 | , cabalOpts :: [String] 57 | , path :: Maybe String 58 | , file :: String 59 | , json :: Bool 60 | } 61 | | ModuleFile 62 | { socket :: Maybe FilePath 63 | , ghcOpts :: [String] 64 | , cabalOpts :: [String] 65 | , module_ :: String 66 | } 67 | | Info 68 | { socket :: Maybe FilePath 69 | , ghcOpts :: [String] 70 | , cabalOpts :: [String] 71 | , path :: Maybe String 72 | , file :: String 73 | , identifier :: String 74 | } 75 | | Type 76 | { socket :: Maybe FilePath 77 | , ghcOpts :: [String] 78 | , cabalOpts :: [String] 79 | , path :: Maybe String 80 | , file :: String 81 | , line :: Int 82 | , col :: Int 83 | } 84 | | FindSymbol 85 | { socket :: Maybe FilePath 86 | , ghcOpts :: [String] 87 | , cabalOpts :: [String] 88 | , symbol :: String 89 | , files :: [String] 90 | } 91 | deriving (Show, Data, Typeable) 92 | 93 | dummyAdmin :: HDevTools 94 | dummyAdmin = Admin 95 | { socket = Nothing 96 | , start_server = False 97 | , noDaemon = False 98 | , status = False 99 | , stop_server = False 100 | } 101 | 102 | dummyCheck :: HDevTools 103 | dummyCheck = Check 104 | { socket = Nothing 105 | , ghcOpts = [] 106 | , cabalOpts = [] 107 | , path = Nothing 108 | , file = "" 109 | , json = False 110 | } 111 | 112 | dummyModuleFile :: HDevTools 113 | dummyModuleFile = ModuleFile 114 | { socket = Nothing 115 | , ghcOpts = [] 116 | , cabalOpts = [] 117 | , module_ = "" 118 | } 119 | 120 | dummyInfo :: HDevTools 121 | dummyInfo = Info 122 | { socket = Nothing 123 | , ghcOpts = [] 124 | , cabalOpts = [] 125 | , path = Nothing 126 | , file = "" 127 | , identifier = "" 128 | } 129 | 130 | dummyType :: HDevTools 131 | dummyType = Type 132 | { socket = Nothing 133 | , ghcOpts = [] 134 | , cabalOpts = [] 135 | , path = Nothing 136 | , file = "" 137 | , line = 0 138 | , col = 0 139 | } 140 | 141 | dummyFindSymbol :: HDevTools 142 | dummyFindSymbol = FindSymbol 143 | { socket = Nothing 144 | , ghcOpts = [] 145 | , cabalOpts = [] 146 | , symbol = "" 147 | , files = [] 148 | } 149 | 150 | admin :: Annotate Ann 151 | admin = record dummyAdmin 152 | [ socket := def += typFile += help "socket file to use" 153 | , start_server := def += help "start server" 154 | , noDaemon := def += help "do not daemonize (only if --start-server)" 155 | , status := def += help "show status of server" 156 | , stop_server := def += help "shutdown the server" 157 | ] += help "Interactions with the server" 158 | 159 | check :: Annotate Ann 160 | check = record dummyCheck 161 | [ socket := def += typFile += help "socket file to use" 162 | , ghcOpts := def += typ "OPTION" += help "ghc options" 163 | #ifdef ENABLE_CABAL 164 | , cabalOpts := def += typ "OPTION" += help "cabal options" 165 | #else 166 | , cabalOpts := def += ignore 167 | #endif 168 | , path := def += typFile += help "path to target file" 169 | , file := def += typFile += argPos 0 += opt "" 170 | , json := def += help "render output as JSON" 171 | ] += help "Check a haskell source file for errors and warnings" 172 | 173 | moduleFile :: Annotate Ann 174 | moduleFile = record dummyModuleFile 175 | [ socket := def += typFile += help "socket file to use" 176 | , ghcOpts := def += typ "OPTION" += help "ghc options" 177 | #ifdef ENABLE_CABAL 178 | , cabalOpts := def += typ "OPTION" += help "cabal options" 179 | #else 180 | , cabalOpts := def += ignore 181 | #endif 182 | , module_ := def += typ "MODULE" += argPos 0 183 | ] += help "Get the haskell source file corresponding to a module name" 184 | 185 | info :: Annotate Ann 186 | info = record dummyInfo 187 | [ socket := def += typFile += help "socket file to use" 188 | , ghcOpts := def += typ "OPTION" += help "ghc options" 189 | #ifdef ENABLE_CABAL 190 | , cabalOpts := def += typ "OPTION" += help "cabal options" 191 | #else 192 | , cabalOpts := def += ignore 193 | #endif 194 | , path := def += typFile += help "path to target file" 195 | , file := def += typFile += argPos 0 += opt "" 196 | , identifier := def += typ "IDENTIFIER" += argPos 1 197 | ] += help "Get info from GHC about the specified identifier" 198 | 199 | type_ :: Annotate Ann 200 | type_ = record dummyType 201 | [ socket := def += typFile += help "socket file to use" 202 | , ghcOpts := def += typ "OPTION" += help "ghc options" 203 | #ifdef ENABLE_CABAL 204 | , cabalOpts := def += typ "OPTION" += help "cabal options" 205 | #else 206 | , cabalOpts := def += ignore 207 | #endif 208 | , path := def += typFile += help "path to target file" 209 | , file := def += typFile += argPos 0 += opt "" 210 | , line := def += typ "LINE" += argPos 1 211 | , col := def += typ "COLUMN" += argPos 2 212 | ] += help "Get the type of the expression at the specified line and column" 213 | 214 | findSymbol :: Annotate Ann 215 | findSymbol = record dummyFindSymbol 216 | [ socket := def += typFile += help "socket file to use" 217 | , ghcOpts := def += typ "OPTION" += help "ghc options" 218 | #ifdef ENABLE_CABAL 219 | , cabalOpts := def += typ "OPTION" += help "cabal options" 220 | #else 221 | , cabalOpts := def += ignore 222 | #endif 223 | , symbol := def += typ "SYMBOL" += argPos 0 224 | , files := def += typFile += args 225 | ] += help "List the modules where the given symbol could be found" 226 | 227 | full :: String -> Annotate Ann 228 | full progName = modes_ [admin += auto, check, moduleFile, info, type_, findSymbol] 229 | += helpArg [name "h", groupname "Help"] 230 | += versionArg [groupname "Help"] 231 | += program progName 232 | += summary (progName ++ ": " ++ fullVersion) 233 | 234 | loadHDevTools :: IO HDevTools 235 | loadHDevTools = do 236 | progName <- getProgName 237 | (cmdArgs_ (full progName) :: IO HDevTools) 238 | -------------------------------------------------------------------------------- /src/CommandLoop.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CommandLoop 3 | ( newCommandLoopState 4 | , Config(..) 5 | , CabalConfig(..) 6 | , newConfig 7 | , startCommandLoop 8 | ) where 9 | 10 | import Control.Monad (when) 11 | import Data.IORef 12 | import Data.List (find, intercalate) 13 | #if __GLASGOW_HASKELL__ < 709 14 | import Control.Applicative ((<$>)) 15 | import Data.Traversable (traverse) 16 | #endif 17 | import MonadUtils (MonadIO, liftIO) 18 | import System.Directory (setCurrentDirectory) 19 | import System.Exit (ExitCode(ExitFailure, ExitSuccess)) 20 | import System.FilePath (takeDirectory) 21 | import qualified ErrUtils 22 | import qualified Exception (ExceptionMonad) 23 | import qualified GHC 24 | import qualified GHC.Paths 25 | import qualified Outputable 26 | import System.Posix.Types (EpochTime) 27 | import System.Posix.Files (getFileStatus, modificationTime) 28 | 29 | import Types (ClientDirective(..), Command(..), CommandExtra(..)) 30 | import Info (getIdentifierInfo, getType) 31 | import FindSymbol (findSymbol) 32 | import Cabal (getPackageGhcOpts) 33 | import Stack 34 | 35 | type ClientSend = ClientDirective -> IO () 36 | 37 | data State = State 38 | { stateWarningsEnabled :: Bool 39 | } 40 | 41 | newCommandLoopState :: IO (IORef State) 42 | newCommandLoopState = do 43 | newIORef $ State 44 | { stateWarningsEnabled = True 45 | } 46 | 47 | data CabalConfig = CabalConfig 48 | { cabalConfigPath :: FilePath 49 | , cabalConfigOpts :: [String] 50 | , cabalConfigLastUpdatedAt :: EpochTime 51 | } 52 | deriving Eq 53 | 54 | mkCabalConfig :: FilePath -> [String] -> IO CabalConfig 55 | mkCabalConfig path opts = do 56 | fileStatus <- getFileStatus path 57 | return $ CabalConfig { cabalConfigPath = path 58 | , cabalConfigOpts = opts 59 | , cabalConfigLastUpdatedAt = modificationTime fileStatus 60 | } 61 | 62 | data Config = Config 63 | { configGhcOpts :: [String] 64 | , configCabal :: Maybe CabalConfig 65 | , configStack :: Maybe StackConfig 66 | } 67 | deriving Eq 68 | 69 | newConfig :: CommandExtra -> IO Config 70 | newConfig cmdExtra = do 71 | mbCabalConfig <- traverse (\path -> mkCabalConfig path (ceCabalOptions cmdExtra)) $ ceCabalConfig cmdExtra 72 | mbStackConfig <- getStackConfig cmdExtra 73 | 74 | return $ Config { configGhcOpts = "-O0" : ceGhcOptions cmdExtra 75 | , configCabal = mbCabalConfig 76 | , configStack = mbStackConfig 77 | } 78 | 79 | type CommandObj = (Command, Config) 80 | 81 | withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a 82 | withWarnings state warningsValue action = do 83 | beforeState <- liftIO $ getWarnings 84 | liftIO $ setWarnings warningsValue 85 | action `GHC.gfinally` 86 | (liftIO $ setWarnings beforeState) 87 | where 88 | getWarnings :: IO Bool 89 | getWarnings = readIORef state >>= return . stateWarningsEnabled 90 | setWarnings :: Bool -> IO () 91 | setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val } 92 | 93 | startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> Config -> Maybe Command -> IO () 94 | startCommandLoop state clientSend getNextCommand initialConfig mbInitialCommand = do 95 | continue <- GHC.runGhc (Just GHC.Paths.libdir) $ do 96 | configResult <- configSession state clientSend initialConfig 97 | case configResult of 98 | Left e -> do 99 | liftIO $ mapM_ clientSend 100 | [ ClientStderr e 101 | , ClientExit (ExitFailure 1) 102 | ] 103 | processNextCommand True 104 | Right _ -> do 105 | doMaybe mbInitialCommand $ \cmd -> sendErrors (runCommand state clientSend cmd) 106 | processNextCommand False 107 | 108 | case continue of 109 | Nothing -> 110 | -- Exit 111 | return () 112 | Just (cmd, config) -> startCommandLoop state clientSend getNextCommand config (Just cmd) 113 | where 114 | processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) 115 | processNextCommand forceReconfig = do 116 | mbNextCmd <- liftIO getNextCommand 117 | case mbNextCmd of 118 | Nothing -> 119 | -- Exit 120 | return Nothing 121 | Just (cmd, config) -> 122 | if forceReconfig || (config /= initialConfig) 123 | then return (Just (cmd, config)) 124 | else sendErrors (runCommand state clientSend cmd) >> processNextCommand False 125 | 126 | sendErrors :: GHC.Ghc () -> GHC.Ghc () 127 | sendErrors action = GHC.gcatch action $ \e -> do 128 | liftIO $ mapM_ clientSend 129 | [ ClientStderr $ GHC.showGhcException e "" 130 | , ClientExit (ExitFailure 1) 131 | ] 132 | return () 133 | 134 | doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () 135 | doMaybe Nothing _ = return () 136 | doMaybe (Just x) f = f x 137 | 138 | configSession :: IORef State -> ClientSend -> Config -> GHC.Ghc (Either String ()) 139 | configSession state clientSend config = do 140 | eCabalGhcOpts <- case configCabal config of 141 | Nothing -> 142 | return $ Right [] 143 | Just cabalConfig -> do 144 | liftIO $ setCurrentDirectory . takeDirectory $ cabalConfigPath cabalConfig 145 | liftIO $ getPackageGhcOpts (cabalConfigPath cabalConfig) (configStack config) (cabalConfigOpts cabalConfig) 146 | case eCabalGhcOpts of 147 | Left e -> return $ Left e 148 | Right cabalGhcOpts -> do 149 | let allGhcOpts = cabalGhcOpts ++ configGhcOpts config 150 | GHC.gcatch (Right <$> updateDynFlags allGhcOpts) 151 | (fmap Left . handleGhcError) 152 | where 153 | updateDynFlags :: [String] -> GHC.Ghc () 154 | updateDynFlags ghcOpts = do 155 | initialDynFlags <- GHC.getSessionDynFlags 156 | let updatedDynFlags = initialDynFlags 157 | { GHC.log_action = logAction state clientSend 158 | , GHC.ghcLink = GHC.NoLink 159 | , GHC.hscTarget = GHC.HscInterpreted 160 | } 161 | (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts) 162 | _ <- GHC.setSessionDynFlags finalDynFlags 163 | return () 164 | 165 | handleGhcError :: GHC.GhcException -> GHC.Ghc String 166 | handleGhcError e = return $ GHC.showGhcException e "" 167 | 168 | runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc () 169 | runCommand _ clientSend (CmdCheck file) = do 170 | let noPhase = Nothing 171 | target <- GHC.guessTarget file noPhase 172 | GHC.setTargets [target] 173 | let handler err = GHC.printException err >> return GHC.Failed 174 | flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) 175 | liftIO $ case flag of 176 | GHC.Succeeded -> clientSend (ClientExit ExitSuccess) 177 | GHC.Failed -> clientSend (ClientExit (ExitFailure 1)) 178 | runCommand _ clientSend (CmdModuleFile moduleName) = do 179 | moduleGraph <- GHC.getModuleGraph 180 | case find (moduleSummaryMatchesModuleName moduleName) moduleGraph of 181 | Nothing -> 182 | liftIO $ mapM_ clientSend 183 | [ ClientStderr "Module not found" 184 | , ClientExit (ExitFailure 1) 185 | ] 186 | Just modSummary -> 187 | case GHC.ml_hs_file (GHC.ms_location modSummary) of 188 | Nothing -> 189 | liftIO $ mapM_ clientSend 190 | [ ClientStderr "Module does not have a source file" 191 | , ClientExit (ExitFailure 1) 192 | ] 193 | Just file -> 194 | liftIO $ mapM_ clientSend 195 | [ ClientStdout file 196 | , ClientExit ExitSuccess 197 | ] 198 | where 199 | moduleSummaryMatchesModuleName modName modSummary = 200 | modName == (GHC.moduleNameString . GHC.moduleName . GHC.ms_mod) modSummary 201 | runCommand state clientSend (CmdInfo file identifier) = do 202 | result <- withWarnings state False $ 203 | getIdentifierInfo file identifier 204 | case result of 205 | Left err -> 206 | liftIO $ mapM_ clientSend 207 | [ ClientStderr err 208 | , ClientExit (ExitFailure 1) 209 | ] 210 | Right info -> liftIO $ mapM_ clientSend 211 | [ ClientStdout info 212 | , ClientExit ExitSuccess 213 | ] 214 | runCommand state clientSend (CmdType file (line, col)) = do 215 | result <- withWarnings state False $ 216 | getType file (line, col) 217 | case result of 218 | Left err -> 219 | liftIO $ mapM_ clientSend 220 | [ ClientStderr err 221 | , ClientExit (ExitFailure 1) 222 | ] 223 | Right types -> liftIO $ do 224 | mapM_ (clientSend . ClientStdout . formatType) types 225 | clientSend (ClientExit ExitSuccess) 226 | where 227 | formatType :: ((Int, Int, Int, Int), String) -> String 228 | formatType ((startLine, startCol, endLine, endCol), t) = 229 | concat 230 | [ show startLine , " " 231 | , show startCol , " " 232 | , show endLine , " " 233 | , show endCol , " " 234 | , "\"", t, "\"" 235 | ] 236 | runCommand state clientSend (CmdFindSymbol symbol files) = do 237 | result <- withWarnings state False $ findSymbol symbol files 238 | case result of 239 | [] -> liftIO $ mapM_ clientSend 240 | [ ClientStderr $ "Couldn't find modules containing '" ++ symbol ++ "'" 241 | , ClientExit (ExitFailure 1) 242 | ] 243 | modules -> liftIO $ mapM_ clientSend 244 | [ ClientStdout (formatModules modules) 245 | , ClientExit ExitSuccess 246 | ] 247 | where 248 | formatModules = intercalate "\n" 249 | 250 | 251 | 252 | #if __GLASGOW_HASKELL__ >= 706 253 | logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () 254 | logAction state clientSend dflags severity srcspan style msg = 255 | let out = Outputable.renderWithStyle dflags fullMsg style 256 | _ = severity 257 | in logActionSend state clientSend severity out 258 | where fullMsg = ErrUtils.mkLocMessage severity srcspan msg 259 | #else 260 | logAction :: IORef State -> ClientSend -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.Message -> IO () 261 | logAction state clientSend severity srcspan style msg = 262 | let out = Outputable.renderWithStyle fullMsg style 263 | _ = severity 264 | in logActionSend state clientSend severity out 265 | where fullMsg = ErrUtils.mkLocMessage srcspan msg 266 | #endif 267 | 268 | logActionSend :: IORef State -> ClientSend -> GHC.Severity -> String -> IO () 269 | logActionSend state clientSend severity out = do 270 | currentState <- readIORef state 271 | when (not (isWarning severity) || stateWarningsEnabled currentState) $ 272 | clientSend (ClientStdout out) 273 | where 274 | isWarning :: GHC.Severity -> Bool 275 | isWarning GHC.SevWarning = True 276 | isWarning _ = False 277 | -------------------------------------------------------------------------------- /src/Daemonize.hs: -------------------------------------------------------------------------------- 1 | module Daemonize 2 | ( daemonize 3 | ) where 4 | 5 | import Control.Monad (when) 6 | import System.Exit (ExitCode(ExitSuccess)) 7 | import System.Posix.Process (exitImmediately, createSession, forkProcess) 8 | import System.Posix.IO 9 | 10 | -- | This goes against the common daemon guidelines and does not change the 11 | -- current working directory! 12 | -- 13 | -- We need the daemon to stay in the current directory for the GHC API to work 14 | daemonize :: Bool -> IO () -> IO () 15 | daemonize exit program = do 16 | _ <- forkProcess child1 17 | when exit $ exitImmediately ExitSuccess 18 | 19 | where 20 | child1 = do 21 | _ <- createSession 22 | _ <- forkProcess child2 23 | exitImmediately ExitSuccess 24 | 25 | child2 = do 26 | mapM_ closeFd [stdInput, stdOutput, stdError] 27 | nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags 28 | mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] 29 | closeFd nullFd 30 | program 31 | -------------------------------------------------------------------------------- /src/FindSymbol.hs: -------------------------------------------------------------------------------- 1 | {-# Language ScopedTypeVariables, CPP #-} 2 | 3 | module FindSymbol 4 | ( findSymbol 5 | ) where 6 | 7 | #if __GLASGOW_HASKELL__ < 710 8 | import Control.Applicative ((<$>)) 9 | import qualified UniqFM 10 | #else 11 | import GHC.PackageDb (exposedName) 12 | import GhcMonad (liftIO) 13 | #endif 14 | 15 | import Control.Monad (filterM) 16 | import Control.Exception 17 | import Data.List (find, nub) 18 | import Data.Maybe (catMaybes, isJust) 19 | import qualified GHC 20 | import qualified Packages as PKG 21 | import qualified Name 22 | import Exception (ghandle) 23 | 24 | type SymbolName = String 25 | type ModuleName = String 26 | 27 | findSymbol :: SymbolName -> [FilePath] -> GHC.Ghc [ModuleName] 28 | findSymbol symbol files = do 29 | -- for the findsymbol command GHC shouldn't output any warnings 30 | -- or errors to stdout for the loaded source files, we're only 31 | -- interested in the module graph of the loaded targets 32 | dynFlags <- GHC.getSessionDynFlags 33 | _ <- GHC.setSessionDynFlags dynFlags { GHC.log_action = \_ _ _ _ _ -> return () } 34 | 35 | fileMods <- concat <$> mapM (findSymbolInFile symbol) files 36 | 37 | -- reset the old log_action 38 | _ <- GHC.setSessionDynFlags dynFlags 39 | 40 | pkgsMods <- findSymbolInPackages symbol 41 | return . nub . map (GHC.moduleNameString . GHC.moduleName) $ fileMods ++ pkgsMods 42 | 43 | 44 | findSymbolInFile :: SymbolName -> FilePath -> GHC.Ghc [GHC.Module] 45 | findSymbolInFile symbol file = do 46 | loadFile 47 | filterM (containsSymbol symbol) =<< fileModules 48 | where 49 | loadFile = do 50 | let noPhase = Nothing 51 | target <- GHC.guessTarget file noPhase 52 | GHC.setTargets [target] 53 | let handler err = GHC.printException err >> return GHC.Failed 54 | _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) 55 | return () 56 | 57 | fileModules = map GHC.ms_mod <$> GHC.getModuleGraph 58 | 59 | 60 | findSymbolInPackages :: SymbolName -> GHC.Ghc [GHC.Module] 61 | findSymbolInPackages symbol = 62 | filterM (containsSymbol symbol) =<< allExposedModules 63 | where 64 | allExposedModules :: GHC.Ghc [GHC.Module] 65 | allExposedModules = do 66 | modNames <- exposedModuleNames 67 | catMaybes <$> mapM findModule modNames 68 | where 69 | exposedModuleNames :: GHC.Ghc [GHC.ModuleName] 70 | #if __GLASGOW_HASKELL__ < 710 71 | exposedModuleNames = 72 | concatMap exposedModules 73 | . UniqFM.eltsUFM 74 | . PKG.pkgIdMap 75 | . GHC.pkgState 76 | <$> GHC.getSessionDynFlags 77 | #else 78 | exposedModuleNames = do 79 | dynFlags <- GHC.getSessionDynFlags 80 | pkgConfigs <- liftIO $ PKG.readPackageConfigs dynFlags 81 | return $ map exposedName (concatMap exposedModules pkgConfigs) 82 | #endif 83 | 84 | exposedModules pkg = if PKG.exposed pkg then PKG.exposedModules pkg else [] 85 | 86 | findModule :: GHC.ModuleName -> GHC.Ghc (Maybe GHC.Module) 87 | findModule moduleName = 88 | ghandle (\(_ :: SomeException) -> return Nothing) 89 | (Just <$> GHC.findModule moduleName Nothing) 90 | 91 | 92 | containsSymbol :: SymbolName -> GHC.Module -> GHC.Ghc Bool 93 | containsSymbol symbol module_ = 94 | isJust . find (== symbol) <$> allExportedSymbols 95 | where 96 | allExportedSymbols = 97 | ghandle (\(_ :: SomeException) -> return []) 98 | (do info <- GHC.getModuleInfo module_ 99 | return $ maybe [] (map Name.getOccString . GHC.modInfoExports) info) 100 | -------------------------------------------------------------------------------- /src/Info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | module Info 4 | ( getIdentifierInfo 5 | , getType 6 | ) where 7 | 8 | import Control.Monad (liftM) 9 | import Data.Generics (GenericQ, mkQ, extQ, gmapQ) 10 | import Data.List (find, sortBy, intersperse) 11 | import Data.Maybe (catMaybes, fromMaybe) 12 | import Data.Typeable (Typeable) 13 | import MonadUtils (liftIO) 14 | import qualified CoreUtils 15 | import qualified Desugar 16 | #if __GLASGOW_HASKELL__ >= 706 17 | import qualified DynFlags 18 | #endif 19 | #if __GLASGOW_HASKELL__ >= 708 20 | import qualified HsExpr 21 | #else 22 | import qualified TcRnTypes 23 | #endif 24 | import qualified GHC 25 | import qualified HscTypes 26 | import qualified NameSet 27 | import qualified Outputable 28 | import qualified PprTyThing 29 | import qualified Pretty 30 | import qualified TcHsSyn 31 | 32 | getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String) 33 | getIdentifierInfo file identifier = 34 | withModSummary file $ \m -> do 35 | #if __GLASGOW_HASKELL__ >= 706 36 | GHC.setContext [GHC.IIModule (GHC.moduleName (GHC.ms_mod m))] 37 | #elif __GLASGOW_HASKELL__ >= 704 38 | GHC.setContext [GHC.IIModule (GHC.ms_mod m)] 39 | #else 40 | GHC.setContext [GHC.ms_mod m] [] 41 | #endif 42 | GHC.handleSourceError (return . Left . show) $ 43 | liftM Right (infoThing identifier) 44 | 45 | getType :: FilePath -> (Int, Int) -> GHC.Ghc (Either String [((Int, Int, Int, Int), String)]) 46 | getType file (line, col) = 47 | withModSummary file $ \m -> do 48 | p <- GHC.parseModule m 49 | typechecked <- GHC.typecheckModule p 50 | types <- processTypeCheckedModule typechecked (line, col) 51 | return (Right types) 52 | 53 | withModSummary :: String -> (HscTypes.ModSummary -> GHC.Ghc (Either String a)) -> GHC.Ghc (Either String a) 54 | withModSummary file action = do 55 | let noPhase = Nothing 56 | target <- GHC.guessTarget file noPhase 57 | GHC.setTargets [target] 58 | 59 | let handler err = GHC.printException err >> return GHC.Failed 60 | flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) 61 | case flag of 62 | GHC.Failed -> return (Left "Error loading targets") 63 | GHC.Succeeded -> do 64 | modSummary <- getModuleSummary file 65 | case modSummary of 66 | Nothing -> return (Left "Module not found in module graph") 67 | Just m -> action m 68 | 69 | getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary) 70 | getModuleSummary file = do 71 | moduleGraph <- GHC.getModuleGraph 72 | case find (moduleSummaryMatchesFilePath file) moduleGraph of 73 | Nothing -> return Nothing 74 | Just moduleSummary -> return (Just moduleSummary) 75 | 76 | moduleSummaryMatchesFilePath :: FilePath -> GHC.ModSummary -> Bool 77 | moduleSummaryMatchesFilePath file moduleSummary = 78 | let location = GHC.ms_location moduleSummary 79 | location_file = GHC.ml_hs_file location 80 | in case location_file of 81 | Just f -> f == file 82 | Nothing -> False 83 | 84 | ------------------------------------------------------------------------------ 85 | -- Most of the following code was taken from the source code of 'ghc-mod' (with 86 | -- some stylistic changes) 87 | -- 88 | -- ghc-mod: 89 | -- http://www.mew.org/~kazu/proj/ghc-mod/ 90 | -- https://github.com/kazu-yamamoto/ghc-mod/ 91 | 92 | processTypeCheckedModule :: GHC.TypecheckedModule -> (Int, Int) -> GHC.Ghc [((Int, Int, Int, Int), String)] 93 | processTypeCheckedModule tcm (line, col) = do 94 | let tcs = GHC.tm_typechecked_source tcm 95 | bs = listifySpans tcs (line, col) :: [GHC.LHsBind GHC.Id] 96 | es = listifySpans tcs (line, col) :: [GHC.LHsExpr GHC.Id] 97 | ps = listifySpans tcs (line, col) :: [GHC.LPat GHC.Id] 98 | bts <- mapM (getTypeLHsBind tcm) bs 99 | ets <- mapM (getTypeLHsExpr tcm) es 100 | pts <- mapM (getTypeLPat tcm) ps 101 | #if __GLASGOW_HASKELL__ >= 706 102 | dflags <- DynFlags.getDynFlags 103 | return $ map (toTup dflags) $ 104 | #else 105 | return $ map toTup $ 106 | #endif 107 | sortBy cmp $ catMaybes $ concat [ets, bts, pts] 108 | where 109 | cmp (a, _) (b, _) 110 | | a `GHC.isSubspanOf` b = LT 111 | | b `GHC.isSubspanOf` a = GT 112 | | otherwise = EQ 113 | 114 | #if __GLASGOW_HASKELL__ >= 706 115 | toTup :: GHC.DynFlags -> (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) 116 | toTup dflags (spn, typ) = (fourInts spn, pretty dflags typ) 117 | #else 118 | toTup :: (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) 119 | toTup (spn, typ) = (fourInts spn, pretty typ) 120 | #endif 121 | 122 | fourInts :: GHC.SrcSpan -> (Int, Int, Int, Int) 123 | fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan 124 | 125 | getSrcSpan :: GHC.SrcSpan -> Maybe (Int, Int, Int, Int) 126 | getSrcSpan (GHC.RealSrcSpan spn) = 127 | Just (GHC.srcSpanStartLine spn 128 | , GHC.srcSpanStartCol spn 129 | , GHC.srcSpanEndLine spn 130 | , GHC.srcSpanEndCol spn) 131 | getSrcSpan _ = Nothing 132 | 133 | getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) 134 | #if __GLASGOW_HASKELL__ >= 708 135 | getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty grp) 136 | #else 137 | getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) 138 | #endif 139 | getTypeLHsBind _ _ = return Nothing 140 | 141 | getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) 142 | #if __GLASGOW_HASKELL__ >= 708 143 | getTypeLHsExpr _ e = do 144 | #else 145 | getTypeLHsExpr tcm e = do 146 | #endif 147 | hs_env <- GHC.getSession 148 | #if __GLASGOW_HASKELL__ >= 708 149 | (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e 150 | #else 151 | let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm 152 | rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm 153 | ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm 154 | (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e 155 | #endif 156 | return () 157 | case mbe of 158 | Nothing -> return Nothing 159 | Just expr -> return $ Just (GHC.getLoc e, CoreUtils.exprType expr) 160 | 161 | getTypeLPat :: GHC.TypecheckedModule -> GHC.LPat GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) 162 | getTypeLPat _ (GHC.L spn pat) = return $ Just (spn, TcHsSyn.hsPatType pat) 163 | 164 | listifySpans :: Typeable a => GHC.TypecheckedSource -> (Int, Int) -> [GHC.Located a] 165 | listifySpans tcs lc = listifyStaged TypeChecker p tcs 166 | where 167 | p (GHC.L spn _) = GHC.isGoodSrcSpan spn && spn `GHC.spans` lc 168 | 169 | listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] 170 | listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) 171 | 172 | #if __GLASGOW_HASKELL__ >= 706 173 | pretty :: GHC.DynFlags -> GHC.Type -> String 174 | pretty dflags = 175 | #else 176 | pretty :: GHC.Type -> String 177 | pretty = 178 | #endif 179 | #if __GLASGOW_HASKELL__ >= 708 180 | Pretty.showDoc Pretty.OneLineMode 0 181 | #else 182 | Pretty.showDocWith Pretty.OneLineMode 183 | #endif 184 | #if __GLASGOW_HASKELL__ >= 706 185 | . Outputable.withPprStyleDoc dflags 186 | #else 187 | . Outputable.withPprStyleDoc 188 | #endif 189 | (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) 190 | #if __GLASGOW_HASKELL__ >= 708 191 | . PprTyThing.pprTypeForUser 192 | #else 193 | . PprTyThing.pprTypeForUser False 194 | #endif 195 | 196 | ------------------------------------------------------------------------------ 197 | -- The following was taken from 'ghc-syb-utils' 198 | -- 199 | -- ghc-syb-utils: 200 | -- https://github.com/nominolo/ghc-syb 201 | 202 | -- | Ghc Ast types tend to have undefined holes, to be filled 203 | -- by later compiler phases. We tag Asts with their source, 204 | -- so that we can avoid such holes based on who generated the Asts. 205 | data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show) 206 | 207 | -- | Like 'everything', but avoid known potholes, based on the 'Stage' that 208 | -- generated the Ast. 209 | everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r 210 | everythingStaged stage k z f x 211 | | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z 212 | | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) 213 | where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool 214 | #if __GLASGOW_HASKELL__ >= 709 215 | postTcType = const (stage Bool 216 | #else 217 | postTcType = const (stage Bool 218 | #endif 219 | fixity = const (stage Bool 220 | 221 | ------------------------------------------------------------------------------ 222 | -- The following code was taken from GHC's ghc/InteractiveUI.hs (with some 223 | -- stylistic changes) 224 | 225 | infoThing :: String -> GHC.Ghc String 226 | infoThing str = do 227 | names <- GHC.parseName str 228 | #if __GLASGOW_HASKELL__ >= 708 229 | mb_stuffs <- mapM (GHC.getInfo False) names 230 | let filtered = filterOutChildren (\(t,_f,_i,_) -> t) (catMaybes mb_stuffs) 231 | #else 232 | mb_stuffs <- mapM GHC.getInfo names 233 | let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) 234 | #endif 235 | unqual <- GHC.getPrintUnqual 236 | #if __GLASGOW_HASKELL__ >= 706 237 | dflags <- DynFlags.getDynFlags 238 | return $ Outputable.showSDocForUser dflags unqual $ 239 | #else 240 | return $ Outputable.showSDocForUser unqual $ 241 | #endif 242 | #if __GLASGOW_HASKELL__ >= 708 243 | Outputable.vcat (intersperse (Outputable.text "") $ map pprInfo filtered) 244 | #else 245 | Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) 246 | #endif 247 | 248 | -- Filter out names whose parent is also there Good 249 | -- example is '[]', which is both a type and data 250 | -- constructor in the same type 251 | filterOutChildren :: (a -> HscTypes.TyThing) -> [a] -> [a] 252 | filterOutChildren get_thing xs 253 | = filter (not . has_parent) xs 254 | where 255 | all_names = NameSet.mkNameSet (map (GHC.getName . get_thing) xs) 256 | #if __GLASGOW_HASKELL__ >= 704 257 | has_parent x = case HscTypes.tyThingParent_maybe (get_thing x) of 258 | #else 259 | has_parent x = case PprTyThing.pprTyThingParent_maybe (get_thing x) of 260 | #endif 261 | Just p -> GHC.getName p `NameSet.elemNameSet` all_names 262 | Nothing -> False 263 | 264 | #if __GLASGOW_HASKELL__ >= 708 265 | pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst]) -> Outputable.SDoc 266 | pprInfo (thing, fixity, insts, _) = 267 | PprTyThing.pprTyThingInContextLoc thing 268 | #elif __GLASGOW_HASKELL__ >= 706 269 | pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc 270 | pprInfo pefas (thing, fixity, insts) = 271 | PprTyThing.pprTyThingInContextLoc pefas thing 272 | #else 273 | pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc 274 | pprInfo pefas (thing, fixity, insts) = 275 | PprTyThing.pprTyThingInContextLoc pefas thing 276 | #endif 277 | Outputable.$$ show_fixity fixity 278 | Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) 279 | where 280 | show_fixity fix 281 | | fix == GHC.defaultFixity = Outputable.empty 282 | | otherwise = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing) 283 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Main where 4 | 5 | #if __GLASGOW_HASKELL__ < 709 6 | import Data.Traversable (traverse) 7 | #endif 8 | 9 | import Data.Maybe (fromMaybe) 10 | import System.Directory (getCurrentDirectory) 11 | import System.Environment (getProgName) 12 | import System.IO (hPutStrLn, stderr) 13 | import System.FilePath ((), isAbsolute, takeDirectory) 14 | 15 | import Cabal (findCabalFile) 16 | import Client (getServerStatus, serverCommand, stopServer) 17 | import CommandArgs 18 | import Daemonize (daemonize) 19 | import Server (startServer, createListenSocket) 20 | import Types (Command(..), CommandExtra(..), emptyCommandExtra) 21 | 22 | absoluteFilePath :: FilePath -> IO FilePath 23 | absoluteFilePath p = if isAbsolute p then return p else do 24 | dir <- getCurrentDirectory 25 | return $ dir p 26 | 27 | 28 | defaultSocketFile :: FilePath 29 | defaultSocketFile = ".hdevtools.sock" 30 | 31 | 32 | fileArg :: HDevTools -> Maybe String 33 | fileArg (Admin {}) = Nothing 34 | fileArg (ModuleFile {}) = Nothing 35 | fileArg args@(Check {}) = Just $ file args 36 | fileArg args@(Info {}) = Just $ file args 37 | fileArg args@(Type {}) = Just $ file args 38 | fileArg (FindSymbol {}) = Nothing 39 | 40 | pathArg' :: HDevTools -> Maybe String 41 | pathArg' (Admin {}) = Nothing 42 | pathArg' (ModuleFile {}) = Nothing 43 | pathArg' args@(Check {}) = path args 44 | pathArg' args@(Info {}) = path args 45 | pathArg' args@(Type {}) = path args 46 | pathArg' (FindSymbol {}) = Nothing 47 | 48 | pathArg :: HDevTools -> Maybe String 49 | pathArg args = case pathArg' args of 50 | Just x -> Just x 51 | Nothing -> fileArg args 52 | 53 | main :: IO () 54 | main = do 55 | args <- loadHDevTools 56 | let argPath = pathArg args 57 | dir <- maybe getCurrentDirectory (return . takeDirectory) argPath 58 | mCabalFile <- findCabalFile dir >>= traverse absoluteFilePath 59 | let extra = emptyCommandExtra 60 | { ceGhcOptions = ghcOpts args 61 | , ceCabalConfig = mCabalFile 62 | , cePath = argPath 63 | , ceCabalOptions = cabalOpts args 64 | } 65 | let defaultSocketPath = maybe "" takeDirectory mCabalFile defaultSocketFile 66 | let sock = fromMaybe defaultSocketPath $ socket args 67 | case args of 68 | Admin {} -> doAdmin sock args extra 69 | Check {} -> doCheck sock args extra 70 | ModuleFile {} -> doModuleFile sock args extra 71 | Info {} -> doInfo sock args extra 72 | Type {} -> doType sock args extra 73 | FindSymbol {} -> doFindSymbol sock args extra 74 | 75 | doAdmin :: FilePath -> HDevTools -> CommandExtra -> IO () 76 | doAdmin sock args _extra 77 | | start_server args = 78 | if noDaemon args then startServer sock Nothing 79 | else do 80 | s <- createListenSocket sock 81 | daemonize True $ startServer sock (Just s) 82 | | status args = getServerStatus sock 83 | | stop_server args = stopServer sock 84 | | otherwise = do 85 | progName <- getProgName 86 | hPutStrLn stderr "You must provide a command. See:" 87 | hPutStrLn stderr $ progName ++ " --help" 88 | 89 | doModuleFile :: FilePath -> HDevTools -> CommandExtra -> IO () 90 | doModuleFile sock args extra = 91 | serverCommand sock (CmdModuleFile (module_ args)) extra 92 | 93 | doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> CommandExtra -> IO () 94 | doFileCommand cmdName cmd sock args extra 95 | | null (file args) = do 96 | progName <- getProgName 97 | hPutStrLn stderr "You must provide a haskell source file. See:" 98 | hPutStrLn stderr $ progName ++ " " ++ cmdName ++ " --help" 99 | | otherwise = do 100 | absFile <- absoluteFilePath $ file args 101 | let args' = args { file = absFile } 102 | serverCommand sock (cmd args') extra 103 | 104 | doCheck :: FilePath -> HDevTools -> CommandExtra -> IO () 105 | doCheck = doFileCommand "check" $ 106 | \args -> CmdCheck (file args) 107 | 108 | doInfo :: FilePath -> HDevTools -> CommandExtra -> IO () 109 | doInfo = doFileCommand "info" $ 110 | \args -> CmdInfo (file args) (identifier args) 111 | 112 | doType :: FilePath -> HDevTools -> CommandExtra -> IO () 113 | doType = doFileCommand "type" $ 114 | \args -> CmdType (file args) (line args, col args) 115 | 116 | doFindSymbol :: FilePath -> HDevTools -> CommandExtra -> IO () 117 | doFindSymbol sock args extra = 118 | serverCommand sock (CmdFindSymbol (symbol args) (files args)) extra 119 | -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | module Server where 2 | 3 | import Control.Exception (bracket, finally, handleJust, tryJust) 4 | import Control.Monad (guard) 5 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 6 | import GHC.IO.Exception (IOErrorType(ResourceVanished)) 7 | import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose) 8 | import System.Directory (removeFile) 9 | import System.Exit (ExitCode(ExitSuccess)) 10 | import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn) 11 | import System.IO.Error (ioeGetErrorType, isAlreadyInUseError, isDoesNotExistError) 12 | 13 | import CommandLoop (newCommandLoopState, Config, newConfig, startCommandLoop) 14 | import Types (ClientDirective(..), Command, emptyCommandExtra, ServerDirective(..)) 15 | import Util (readMaybe) 16 | 17 | createListenSocket :: FilePath -> IO Socket 18 | createListenSocket socketPath = do 19 | r <- tryJust (guard . isAlreadyInUseError) $ listenOn (UnixSocket socketPath) 20 | case r of 21 | Right socket -> return socket 22 | Left _ -> do 23 | removeFile socketPath 24 | listenOn (UnixSocket socketPath) 25 | 26 | startServer :: FilePath -> Maybe Socket -> IO () 27 | startServer socketPath mbSock = do 28 | case mbSock of 29 | Nothing -> bracket (createListenSocket socketPath) cleanup go 30 | Just sock -> (go sock) `finally` (cleanup sock) 31 | where 32 | cleanup :: Socket -> IO () 33 | cleanup sock = do 34 | sClose sock 35 | removeSocketFile 36 | 37 | go :: Socket -> IO () 38 | go sock = do 39 | state <- newCommandLoopState 40 | currentClient <- newIORef Nothing 41 | config <- newConfig emptyCommandExtra 42 | startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) config Nothing 43 | 44 | removeSocketFile :: IO () 45 | removeSocketFile = do 46 | -- Ignore possible error if socket file does not exist 47 | _ <- tryJust (guard . isDoesNotExistError) $ removeFile socketPath 48 | return () 49 | 50 | clientSend :: IORef (Maybe Handle) -> ClientDirective -> IO () 51 | clientSend currentClient clientDirective = do 52 | mbH <- readIORef currentClient 53 | case mbH of 54 | Just h -> ignoreEPipe $ do 55 | hPutStrLn h (show clientDirective) 56 | hFlush h 57 | Nothing -> return () 58 | where 59 | -- EPIPE means that the client is no longer there. 60 | ignoreEPipe = handleJust (guard . isEPipe) (const $ return ()) 61 | isEPipe = (==ResourceVanished) . ioeGetErrorType 62 | 63 | getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, Config)) 64 | getNextCommand currentClient sock = do 65 | checkCurrent <- readIORef currentClient 66 | case checkCurrent of 67 | Just h -> hClose h 68 | Nothing -> return () 69 | (h, _, _) <- accept sock 70 | writeIORef currentClient (Just h) 71 | msg <- hGetLine h -- TODO catch exception 72 | let serverDirective = readMaybe msg 73 | case serverDirective of 74 | Nothing -> do 75 | clientSend currentClient $ ClientUnexpectedError $ 76 | "The client sent an invalid message to the server: " ++ show msg 77 | getNextCommand currentClient sock 78 | Just (SrvCommand cmd cmdExtra) -> do 79 | config <- newConfig cmdExtra 80 | return $ Just (cmd, config) 81 | Just SrvStatus -> do 82 | mapM_ (clientSend currentClient) $ 83 | [ ClientStdout "Server is running." 84 | , ClientExit ExitSuccess 85 | ] 86 | getNextCommand currentClient sock 87 | Just SrvExit -> do 88 | mapM_ (clientSend currentClient) $ 89 | [ ClientStdout "Shutting down server." 90 | , ClientExit ExitSuccess 91 | ] 92 | -- Must close the handle here because we are exiting the loop so it 93 | -- won't be closed in the code above 94 | hClose h 95 | return Nothing 96 | -------------------------------------------------------------------------------- /src/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Stack 3 | ( -- * The bits of information needed from `stack` 4 | StackConfig (..) 5 | -- * Run `stack exec` to compute @StackConfig@ 6 | , getStackConfig 7 | ) where 8 | 9 | import Data.Maybe (listToMaybe) 10 | import Data.Char (isSpace) 11 | 12 | #if __GLASGOW_HASKELL__ < 709 13 | import Control.Applicative((<$>), (<*>)) 14 | import System.IO 15 | #endif 16 | 17 | import System.Process 18 | import System.FilePath 19 | import System.Directory 20 | import Control.Monad (filterM) 21 | import Control.Exception 22 | import Types 23 | 24 | 25 | -- | This module adds support for `stack`, as follows: 26 | -- 1. Figure out if the target-file is in a stack project, 27 | -- 2. If `stack` in available in PATH, run `stack exec` to extract 28 | -- `StackConfig` 29 | -- 3. The `StackConfig` is used to suitably alter the cabal ConfigFlags in 30 | -- Cabal.hs 31 | 32 | 33 | -- TODO: Move into Types? 34 | data StackConfig = StackConfig { stackDist :: FilePath 35 | , stackDbs :: [FilePath] 36 | } 37 | deriving (Eq, Show) 38 | 39 | -------------------------------------------------------------------------------- 40 | getStackConfig :: CommandExtra -> IO (Maybe StackConfig) 41 | -------------------------------------------------------------------------------- 42 | getStackConfig ce = case cePath ce of 43 | Nothing -> return Nothing 44 | Just p -> getStackConfig' p 45 | 46 | getStackConfig' :: FilePath -> IO (Maybe StackConfig) 47 | getStackConfig' p = do 48 | mbYaml <- getStackYaml p 49 | case mbYaml of 50 | Nothing -> return Nothing 51 | Just _ -> do mdbs <- getStackDbs p 52 | mdst <- getStackDist p 53 | return $ StackConfig <$> mdst <*> mdbs 54 | 55 | -------------------------------------------------------------------------------- 56 | getStackYaml :: FilePath -> IO (Maybe FilePath) 57 | -------------------------------------------------------------------------------- 58 | getStackYaml p = listToMaybe <$> filterM doesFileExist paths 59 | where 60 | paths = [ d "stack.yaml" | d <- pathsToRoot dir] 61 | dir = takeDirectory p 62 | 63 | pathsToRoot :: FilePath -> [FilePath] 64 | pathsToRoot p 65 | | p == parent = [p] 66 | | otherwise = p : pathsToRoot parent 67 | where 68 | parent = takeDirectory p 69 | 70 | -------------------------------------------------------------------------------- 71 | getStackDist :: FilePath -> IO (Maybe FilePath) 72 | -------------------------------------------------------------------------------- 73 | getStackDist p = (trim <$>) <$> execInPath cmd p 74 | where 75 | cmd = "stack path --dist-dir" 76 | -- dir = takeDirectory p 77 | -- splice = (dir ) . trim 78 | 79 | -------------------------------------------------------------------------------- 80 | getStackDbs :: FilePath -> IO (Maybe [FilePath]) 81 | -------------------------------------------------------------------------------- 82 | getStackDbs p = do mpp <- execInPath cmd p 83 | case mpp of 84 | Just pp -> Just <$> extractDbs pp 85 | Nothing -> return Nothing 86 | where 87 | cmd = "stack --verbosity quiet exec printenv GHC_PACKAGE_PATH" 88 | 89 | extractDbs :: String -> IO [FilePath] 90 | extractDbs = filterM doesDirectoryExist . stringPaths 91 | 92 | stringPaths :: String -> [String] 93 | stringPaths = splitBy ':' . trim 94 | 95 | -------------------------------------------------------------------------------- 96 | -- | Generic Helpers 97 | -------------------------------------------------------------------------------- 98 | 99 | splitBy :: Char -> String -> [String] 100 | splitBy c str 101 | | null str' = [x] 102 | | otherwise = x : splitBy c (tail str') 103 | where 104 | (x, str') = span (c /=) str 105 | 106 | trim :: String -> String 107 | trim = f . f 108 | where 109 | f = reverse . dropWhile isSpace 110 | 111 | #if __GLASGOW_HASKELL__ < 709 112 | execInPath :: String -> FilePath -> IO (Maybe String) 113 | execInPath cmd p = do 114 | eIOEstr <- try $ createProcess prc :: IO (Either IOError ProcH) 115 | case eIOEstr of 116 | Right (_, Just h, _, _) -> Just <$> getClose h 117 | Right (_, Nothing, _, _) -> return Nothing 118 | -- This error is most likely "/bin/sh: stack: command not found" 119 | -- which is caused by the package containing a stack.yaml file but 120 | -- no stack command is in the PATH. 121 | Left _ -> return Nothing 122 | where 123 | prc = (shell cmd) { cwd = Just $ takeDirectory p } 124 | 125 | getClose :: Handle -> IO String 126 | getClose h = do 127 | str <- hGetContents h 128 | hClose h 129 | return str 130 | 131 | type ProcH = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) 132 | 133 | -- Not deleting this because this is likely more robust than the above! (but 134 | -- only works on process-1.2.3.0 onwards 135 | 136 | #else 137 | execInPath :: String -> FilePath -> IO (Maybe String) 138 | execInPath cmd p = do 139 | eIOEstr <- try $ readCreateProcess prc "" :: IO (Either IOError String) 140 | return $ case eIOEstr of 141 | Right s -> Just s 142 | -- This error is most likely "/bin/sh: stack: command not found" 143 | -- which is caused by the package containing a stack.yaml file but 144 | -- no stack command is in the PATH. 145 | Left _ -> Nothing 146 | where 147 | prc = (shell cmd) { cwd = Just $ takeDirectory p } 148 | #endif 149 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types 2 | ( ServerDirective(..) 3 | , ClientDirective(..) 4 | , Command(..) 5 | , CommandExtra(..) 6 | , emptyCommandExtra 7 | ) where 8 | 9 | import System.Exit (ExitCode) 10 | 11 | data CommandExtra = CommandExtra 12 | { ceGhcOptions :: [String] 13 | , ceCabalConfig :: Maybe FilePath 14 | , cePath :: Maybe FilePath 15 | , ceCabalOptions :: [String] 16 | } deriving (Read, Show) 17 | 18 | emptyCommandExtra :: CommandExtra 19 | emptyCommandExtra = CommandExtra { ceGhcOptions = [] 20 | , ceCabalConfig = Nothing 21 | , cePath = Nothing 22 | , ceCabalOptions = [] 23 | } 24 | 25 | data ServerDirective 26 | = SrvCommand Command CommandExtra 27 | | SrvStatus 28 | | SrvExit 29 | deriving (Read, Show) 30 | 31 | data ClientDirective 32 | = ClientStdout String 33 | | ClientStderr String 34 | | ClientExit ExitCode 35 | | ClientUnexpectedError String -- ^ For unexpected errors that should not happen 36 | deriving (Read, Show) 37 | 38 | data Command 39 | = CmdCheck FilePath 40 | | CmdModuleFile String 41 | | CmdInfo FilePath String 42 | | CmdType FilePath (Int, Int) 43 | | CmdFindSymbol String [String] 44 | deriving (Read, Show) 45 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util 2 | ( readMaybe 3 | ) where 4 | 5 | -- Taken from: 6 | -- http://stackoverflow.com/questions/8066850/why-doesnt-haskells-prelude-read-return-a-maybe/8080084#8080084 7 | readMaybe :: (Read a) => String -> Maybe a 8 | readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of 9 | [x] -> Just x 10 | _ -> Nothing 11 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | 6 | # for GHC 7.8 7 | # resolver: lts-2.15 8 | 9 | # for GHC 7.10 10 | resolver: nightly-2015-08-26 11 | -------------------------------------------------------------------------------- /test_all_hsenv.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ./test_hsenv.sh `echo .hsenv_* | sed -e 's/.hsenv_//g'` 3 | -------------------------------------------------------------------------------- /test_hsenv.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | if [ $# -lt 1 ] 6 | then 7 | echo "Usage:" 8 | echo "$0 [ ...]" 9 | exit 2 10 | fi 11 | 12 | for i in $* 13 | do 14 | source .hsenv_$i/bin/activate 15 | cabal build 16 | export HDEVTOOLS=./dist_$i/build/hdevtools/hdevtools 17 | ./tests/test_runner.sh 18 | deactivate_hsenv 19 | done 20 | 21 | echo 22 | echo 'All Tests Passed in:' $* 23 | -------------------------------------------------------------------------------- /tests/Child.hs: -------------------------------------------------------------------------------- 1 | module Child where 2 | 3 | import Parent 4 | 5 | child :: String 6 | child = "child of " ++ parent 7 | -------------------------------------------------------------------------------- /tests/Parent.hs: -------------------------------------------------------------------------------- 1 | module Parent where 2 | 3 | parent :: String 4 | parent = "parent" 5 | -------------------------------------------------------------------------------- /tests/SampleError.hs: -------------------------------------------------------------------------------- 1 | -- Sample Module used for testing 2 | 3 | -- This module should cause a compilation error: 4 | -- 5 | -- Sample2.hs:9:1: parse error (possibly incorrect indentation) 6 | 7 | module SampleError where 8 | 9 | a = foo 10 | -------------------------------------------------------------------------------- /tests/Simple.hs: -------------------------------------------------------------------------------- 1 | -- Sample Module used for testing 2 | 3 | -- This module contains no errors or warnings 4 | module Sample1 where 5 | 6 | increment :: Int -> Int 7 | increment x = x + 1 8 | -------------------------------------------------------------------------------- /tests/test_module_file.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | SOCK=`mktemp -u` 6 | 7 | $HDEVTOOLS check --socket=$SOCK Child.hs 8 | 9 | PARENT=`$HDEVTOOLS modulefile --socket=$SOCK Parent` 10 | 11 | [ "$PARENT" = "./Parent.hs" ] 12 | 13 | $HDEVTOOLS --socket=$SOCK --stop-server 14 | -------------------------------------------------------------------------------- /tests/test_runner.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | ALL_TESTS="\ 6 | test_start_stop.sh \ 7 | test_simple_check.sh \ 8 | test_sample_error.sh \ 9 | test_module_file.sh \ 10 | " 11 | 12 | if [ ! $HDEVTOOLS ] 13 | then 14 | echo 'You must set the HDEVTOOLS environment variable to the path of the hdevtools binary' 15 | exit 1 16 | fi 17 | 18 | case "$HDEVTOOLS" in 19 | */*) 20 | # Convert relative path to absolute: 21 | export HDEVTOOLS=`pwd`/$HDEVTOOLS 22 | esac 23 | 24 | echo $HDEVTOOLS 25 | 26 | if [ $# -ne 0 ] 27 | then 28 | TESTS=$* 29 | else 30 | TESTS=$ALL_TESTS 31 | echo 'Running All Tests' 32 | fi 33 | 34 | echo '------------------------------------------------------------------------' 35 | 36 | cd `dirname $0` 37 | 38 | ERRORS=0 39 | for i in $TESTS 40 | do 41 | echo $i 42 | echo 43 | if sh $i 44 | then 45 | echo 'Test OK' 46 | else 47 | echo 'Test FAILED' 48 | ERRORS=`expr $ERRORS + 1` 49 | fi 50 | echo '------------------------------------------------------------------------' 51 | done 52 | 53 | if [ $ERRORS = 0 ] 54 | then 55 | echo 'All Tests OK' 56 | else 57 | echo $ERRORS 'FAILED Tests' 58 | fi 59 | exit $ERRORS 60 | -------------------------------------------------------------------------------- /tests/test_sample_error.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | SOCK=`mktemp -u` 6 | 7 | EXPECTED_ERRORS='SampleError.hs:9:5: Not in scope: `foo'\''' 8 | 9 | if ERRORS=`$HDEVTOOLS check --socket=$SOCK SampleError.hs` 10 | then 11 | false 12 | elsh 13 | [ "$ERRORS" = "$EXPECTED_ERRORS" ] 14 | fi 15 | 16 | $HDEVTOOLS --socket=$SOCK --stop-server 17 | -------------------------------------------------------------------------------- /tests/test_simple_check.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | SOCK=`mktemp -u` 6 | 7 | ERRORS=`$HDEVTOOLS check --socket=$SOCK Simple.hs` 8 | 9 | [ -z "$ERRORS" ] 10 | 11 | $HDEVTOOLS --socket=$SOCK --stop-server 12 | -------------------------------------------------------------------------------- /tests/test_start_stop.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | SOCK=`mktemp -u` 6 | 7 | echo '> Starting the server' 8 | $HDEVTOOLS --socket=$SOCK --start-server 9 | 10 | echo '> Checking status' 11 | $HDEVTOOLS --socket=$SOCK --status 12 | 13 | echo '> Checking that the socket file exists' 14 | if [ ! -S $SOCK ]; then false; fi 15 | 16 | echo '> Stopping the server' 17 | $HDEVTOOLS --socket=$SOCK --stop-server 18 | 19 | echo '> Checking that the socket file no longer exists' 20 | if [ -e $SOCK ]; then false; fi 21 | --------------------------------------------------------------------------------