├── AUTHORS ├── LICENSE ├── README.md ├── Setup.hs ├── hdevtools.cabal ├── src ├── Client.hs ├── CommandArgs.hs ├── CommandLoop.hs ├── Daemonize.hs ├── GhcTypes.hs ├── Info.hs ├── Main.hs ├── Server.hs ├── Types.hs └── Util.hs ├── 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 | 4 | Persistent GHC powered background server for FAST Haskell development tools 5 | 6 | About 7 | ----- 8 | 9 | `hdevtools` is a backend for text editor plugins, to allow for things such as 10 | syntax and type checking of Haskell code, and retrieving type information, all 11 | directly from within your text editor. 12 | 13 | The advantage that `hdevtools` has over competitors, is that it runs silently 14 | in a persistent background process, and therefore is able to keeps all of your 15 | Haskell modules and dependent libraries loaded in memory. This way, when you 16 | change only a single source file, only it needs to be reloaded and rechecked, 17 | instead of having to reload everything. 18 | 19 | This makes `hdevtools` very fast for checking syntax and type errors (runs just 20 | as fast as the `:reload` command in GHCi). 21 | 22 | In fact, syntax and type checking is so fast, that you can safely enable auto 23 | checking on every save. Even for huge projects, checking is nearly instant. 24 | 25 | Once you start using `hdevtools` and you get used to having your errors shown 26 | to you instantly (without having to switch back and forth between GHCi and your 27 | editor), and shown directly on your code, in your editor (without having to 28 | wait forever for GHC to run) you will wonder how you ever lived without it. 29 | 30 | In addition to checking Haskell source code for errors, `hdevtools` has tools 31 | for getting info about identifiers, and getting type information for snippets 32 | of code. 33 | 34 | Text Editor Integration 35 | ----------------------- 36 | 37 | `hdevtools` is designed to be integrated into text editors. The list of current 38 | editor plugins that supply this integration is below. 39 | 40 | But before you do anything, you must first install `hdevtools` itself. The 41 | easiest way is from [Hackage][1] via cabal install: 42 | 43 | $ cabal install hdevtools 44 | 45 | Then you should install one or more of the following editor plugins: 46 | 47 | ### Vim - [Syntastic][2] ### 48 | 49 | [Syntastic][2] is a popular syntax checking plugin for Vim, and is the 50 | recommended Vim integration of `hdevtools` syntax and type checking. Recent 51 | versions of Syntastic(since Sep. 2012) have builtin support for `hdevtools`. 52 | 53 | Simply install `hdevtools` (as above) and [Syntastic][2], and it will 54 | automatically check your Haskell files. 55 | 56 | [Syntastic][2] will respect the `g:hdevtools_options` variable (the same one as 57 | used by [vim-hdevtools][3], see below). See the section "Specifying GHC 58 | Options" below for details how to use it. 59 | 60 | ### Vim - [vim-hdevtools][3] ### 61 | 62 | In addition to Syntastic, it is recommended that you also use 63 | [`vim-hdevtools`][3] for additional functionality. 64 | 65 | [`vim-hdevtools`][3] offers integration with the rest of the `hdevtools` tools, 66 | including retrieving info about the identifier under the cursor, and getting 67 | the type of the code under the cursor. Refer to its documentation for more 68 | details. 69 | 70 | ### Emacs - [flycheck][5] ### 71 | 72 | [Flycheck][5] is a modern batteries-included 73 | syntax checker for Emacs, and there is a [flycheck-hdevtools][6] checker available. 74 | 75 | ### Manual Editor Integration for any Editor ### 76 | 77 | Most editors allow you to run a `make` command, and will then parse the output 78 | for errors and show line numbers, allowing you to jump between errors. 79 | 80 | The `hdevtools check` command is suitable for such usage. 81 | 82 | For example, in Vim something like this will work: 83 | 84 | :let &makeprg='hdevtools check %' 85 | 86 | (Vim will replace the `%` character with the name of the current file). Then 87 | you can run 88 | 89 | :make 90 | 91 | And Vim will invoke `hdevtools` to check the current file for errors, and then 92 | show a list of them and allow jumping to them. 93 | 94 | See the "Command Line Usage" section below for more information. 95 | 96 | Command Line Usage 97 | ------------------ 98 | 99 | Note: When using one of the above editor plugins, you don't really need to know 100 | this. 101 | 102 | ### Available Commands and Help ### 103 | 104 | For the list of commands available, run: 105 | 106 | $ hdevtools --help 107 | 108 | To get help for a specific command, run: 109 | 110 | $ hdevtools [COMMAND] --help 111 | 112 | For example: 113 | 114 | $ hdevtools check --help 115 | 116 | ### The `hdevtools` background process ### 117 | 118 | The first time `hdevtools` runs a command, it will spawn a background process 119 | that will remain running forever. You can check the status of this background 120 | process by running: 121 | 122 | $ hdevtools --status 123 | 124 | You can shutdown the background process by running: 125 | 126 | $ hdevtools --stop-server 127 | 128 | Communication with the background process is done through a unix socket file. 129 | The default name is `.hdevtools.sock`, in the current directory. This allows 130 | you to use `hdevtools` with multiple projects simultaneously, without the 131 | background processes getting in the way of each other. 132 | 133 | You can use a different socket file name with the `--socket` option, which 134 | should be used for each invocation of `hdevtools`. Remember that when telling 135 | `hdevtools` to check a Haskell file, paths are relative to the path of the 136 | background process, not your current directory. This can cause problems, and 137 | therefore it is recommended that you leave the socket file as the default, and 138 | always run `hdevtools` from the same directory. 139 | 140 | ### Specifying GHC Options ### 141 | 142 | For most non-trivial projects, you will need to tell `hdevtools` about 143 | additional GHC options that your project requires. 144 | 145 | All `hdevtools` commands accept a `-g` flag for this purpose. 146 | 147 | For example: 148 | 149 | * Your project source code is in the directory `src` 150 | * You want to use the GHC option `-Wall` 151 | * You want to hide the package `transformers` to prevent conflicts 152 | 153 | Invoke `hdevtools` with something like this: 154 | 155 | $ hdevtools check -g -isrc -g -Wall -g -hide-package -g transformers Foo.hs 156 | 157 | Notice that a `-g` flag is inserted before each GHC option. Don't try to string 158 | multiple GHC options together after a single `-g` flag: 159 | 160 | This won't work: 161 | 162 | $ hdevtools check -g '-hide-package transformers' Foo.hs 163 | 164 | The Vim plugins allow setting GHC options in the `g:hdevtools_options` 165 | variable. For example, for the above project, put the following in your 166 | `.vimrc`: 167 | 168 | let g:hdevtools_options = '-g -isrc -g -Wall -g -hide-package -g transformers' 169 | 170 | In general, you will need to pass to `hdevtools` the same GHC options that you 171 | would pass to GHCi. 172 | 173 | Credits 174 | ------- 175 | 176 | `hdevtools` was inspired by [ghcmod][4], but has the advantage that due to its 177 | client-server architecture it is much faster. 178 | 179 | [1]: http://hackage.haskell.org/package/hdevtools 180 | [2]: https://github.com/scrooloose/syntastic 181 | [3]: https://github.com/bitc/vim-hdevtools 182 | [4]: http://www.mew.org/~kazu/proj/ghc-mod/en/ 183 | [5]: https://github.com/flycheck/flycheck 184 | [6]: https://github.com/flycheck/flycheck-hdevtools 185 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hdevtools.cabal: -------------------------------------------------------------------------------- 1 | name: hdevtools 2 | version: 0.1.0.5 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: mutantlemon@gmail.com 34 | copyright: See AUTHORS file 35 | category: Development 36 | homepage: https://github.com/bitc/hdevtools/ 37 | bug-reports: https://github.com/bitc/hdevtools/issues/ 38 | build-type: Simple 39 | cabal-version: >=1.8 40 | 41 | source-repository head 42 | type: git 43 | location: git://github.com/bitc/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: Client, 51 | CommandArgs, 52 | CommandLoop, 53 | Daemonize, 54 | GhcTypes, 55 | Info, 56 | Server, 57 | Types, 58 | Util, 59 | Paths_hdevtools 60 | build-depends: base == 4.*, 61 | cmdargs, 62 | directory, 63 | ghc >= 7.2, 64 | ghc-paths, 65 | syb, 66 | network == 2.8.0.1, 67 | time, 68 | unix 69 | -------------------------------------------------------------------------------- /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(..), 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 -> [String] -> IO () 38 | serverCommand sock cmd ghcOpts = do 39 | r <- tryJust (guard . isDoesNotExistError) (connect sock) 40 | case r of 41 | Right h -> do 42 | hPutStrLn h $ show (SrvCommand cmd ghcOpts) 43 | hFlush h 44 | startClientReadLoop h 45 | Left _ -> do 46 | s <- createListenSocket sock 47 | daemonize False $ startServer sock (Just s) 48 | serverCommand sock cmd ghcOpts 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 | fullVersion :: String 28 | fullVersion = 29 | concat 30 | [ programVersion 31 | , " (ghc-", Config.cProjectVersion, "-", arch, "-", os, ")" 32 | ] 33 | 34 | data HDevTools 35 | = Admin 36 | { socket :: Maybe FilePath 37 | , start_server :: Bool 38 | , noDaemon :: Bool 39 | , status :: Bool 40 | , stop_server :: Bool 41 | } 42 | | Check 43 | { socket :: Maybe FilePath 44 | , ghcOpts :: [String] 45 | , file :: String 46 | } 47 | | ModuleFile 48 | { socket :: Maybe FilePath 49 | , ghcOpts :: [String] 50 | , module_ :: String 51 | } 52 | | Info 53 | { socket :: Maybe FilePath 54 | , ghcOpts :: [String] 55 | , file :: String 56 | , identifier :: String 57 | } 58 | | Type 59 | { socket :: Maybe FilePath 60 | , ghcOpts :: [String] 61 | , file :: String 62 | , line :: Int 63 | , col :: Int 64 | } 65 | deriving (Show, Data, Typeable) 66 | 67 | dummyAdmin :: HDevTools 68 | dummyAdmin = Admin 69 | { socket = Nothing 70 | , start_server = False 71 | , noDaemon = False 72 | , status = False 73 | , stop_server = False 74 | } 75 | 76 | dummyCheck :: HDevTools 77 | dummyCheck = Check 78 | { socket = Nothing 79 | , ghcOpts = [] 80 | , file = "" 81 | } 82 | 83 | dummyModuleFile :: HDevTools 84 | dummyModuleFile = ModuleFile 85 | { socket = Nothing 86 | , ghcOpts = [] 87 | , module_ = "" 88 | } 89 | 90 | dummyInfo :: HDevTools 91 | dummyInfo = Info 92 | { socket = Nothing 93 | , ghcOpts = [] 94 | , file = "" 95 | , identifier = "" 96 | } 97 | 98 | dummyType :: HDevTools 99 | dummyType = Type 100 | { socket = Nothing 101 | , ghcOpts = [] 102 | , file = "" 103 | , line = 0 104 | , col = 0 105 | } 106 | 107 | admin :: Annotate Ann 108 | admin = record dummyAdmin 109 | [ socket := def += typFile += help "socket file to use" 110 | , start_server := def += help "start server" 111 | , noDaemon := def += help "do not daemonize (only if --start-server)" 112 | , status := def += help "show status of server" 113 | , stop_server := def += help "shutdown the server" 114 | ] += help "Interactions with the server" 115 | 116 | check :: Annotate Ann 117 | check = record dummyCheck 118 | [ socket := def += typFile += help "socket file to use" 119 | , ghcOpts := def += typ "OPTION" += help "ghc options" 120 | , file := def += typFile += argPos 0 += opt "" 121 | ] += help "Check a haskell source file for errors and warnings" 122 | 123 | moduleFile :: Annotate Ann 124 | moduleFile = record dummyModuleFile 125 | [ socket := def += typFile += help "socket file to use" 126 | , ghcOpts := def += typ "OPTION" += help "ghc options" 127 | , module_ := def += typ "MODULE" += argPos 0 128 | ] += help "Get the haskell source file corresponding to a module name" 129 | 130 | info :: Annotate Ann 131 | info = record dummyInfo 132 | [ socket := def += typFile += help "socket file to use" 133 | , ghcOpts := def += typ "OPTION" += help "ghc options" 134 | , file := def += typFile += argPos 0 += opt "" 135 | , identifier := def += typ "IDENTIFIER" += argPos 1 136 | ] += help "Get info from GHC about the specified identifier" 137 | 138 | type_ :: Annotate Ann 139 | type_ = record dummyType 140 | [ socket := def += typFile += help "socket file to use" 141 | , ghcOpts := def += typ "OPTION" += help "ghc options" 142 | , file := def += typFile += argPos 0 += opt "" 143 | , line := def += typ "LINE" += argPos 1 144 | , col := def += typ "COLUMN" += argPos 2 145 | ] += help "Get the type of the expression at the specified line and column" 146 | 147 | full :: String -> Annotate Ann 148 | full progName = modes_ [admin += auto, check, moduleFile, info, type_] 149 | += helpArg [name "h", groupname "Help"] 150 | += versionArg [groupname "Help"] 151 | += program progName 152 | += summary (progName ++ ": " ++ fullVersion) 153 | 154 | loadHDevTools :: IO HDevTools 155 | loadHDevTools = do 156 | progName <- getProgName 157 | (cmdArgs_ (full progName) :: IO HDevTools) 158 | -------------------------------------------------------------------------------- /src/CommandLoop.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CommandLoop 3 | ( newCommandLoopState 4 | , startCommandLoop 5 | ) where 6 | 7 | import Control.Monad (when) 8 | import Data.IORef 9 | import Data.List (find) 10 | import MonadUtils (MonadIO, liftIO) 11 | import System.Exit (ExitCode(ExitFailure, ExitSuccess)) 12 | import qualified ErrUtils 13 | import qualified Exception (ExceptionMonad) 14 | import qualified GHC 15 | import qualified GHC.Paths 16 | import qualified Outputable 17 | 18 | import Types (ClientDirective(..), Command(..)) 19 | import GhcTypes (getModSummaries) 20 | import Info (getIdentifierInfo, getType) 21 | 22 | type CommandObj = (Command, [String]) 23 | 24 | type ClientSend = ClientDirective -> IO () 25 | 26 | data State = State 27 | { stateWarningsEnabled :: Bool 28 | } 29 | 30 | newCommandLoopState :: IO (IORef State) 31 | newCommandLoopState = do 32 | newIORef $ State 33 | { stateWarningsEnabled = True 34 | } 35 | 36 | withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a 37 | withWarnings state warningsValue action = do 38 | beforeState <- liftIO $ getWarnings 39 | liftIO $ setWarnings warningsValue 40 | action `GHC.gfinally` 41 | (liftIO $ setWarnings beforeState) 42 | where 43 | getWarnings :: IO Bool 44 | getWarnings = readIORef state >>= return . stateWarningsEnabled 45 | setWarnings :: Bool -> IO () 46 | setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val } 47 | 48 | startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO () 49 | startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do 50 | continue <- GHC.runGhc (Just GHC.Paths.libdir) $ do 51 | configOk <- GHC.gcatch (configSession state clientSend initialGhcOpts >> return True) 52 | handleConfigError 53 | if configOk 54 | then do 55 | doMaybe mbInitial $ \cmd -> sendErrors (runCommand state clientSend cmd) 56 | processNextCommand False 57 | else processNextCommand True 58 | 59 | case continue of 60 | Nothing -> 61 | -- Exit 62 | return () 63 | Just (cmd, ghcOpts) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just cmd) 64 | where 65 | processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) 66 | processNextCommand forceReconfig = do 67 | mbNextCmd <- liftIO getNextCommand 68 | case mbNextCmd of 69 | Nothing -> 70 | -- Exit 71 | return Nothing 72 | Just (cmd, ghcOpts) -> 73 | if forceReconfig || (ghcOpts /= initialGhcOpts) 74 | then return (Just (cmd, ghcOpts)) 75 | else sendErrors (runCommand state clientSend cmd) >> processNextCommand False 76 | 77 | sendErrors :: GHC.Ghc () -> GHC.Ghc () 78 | sendErrors action = GHC.gcatch action (\x -> handleConfigError x >> return ()) 79 | 80 | handleConfigError :: GHC.GhcException -> GHC.Ghc Bool 81 | handleConfigError e = do 82 | liftIO $ mapM_ clientSend 83 | [ ClientStderr (GHC.showGhcException e "") 84 | , ClientExit (ExitFailure 1) 85 | ] 86 | return False 87 | 88 | doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () 89 | doMaybe Nothing _ = return () 90 | doMaybe (Just x) f = f x 91 | 92 | configSession :: IORef State -> ClientSend -> [String] -> GHC.Ghc () 93 | configSession state clientSend ghcOpts = do 94 | initialDynFlags <- GHC.getSessionDynFlags 95 | let updatedDynFlags = initialDynFlags 96 | { GHC.log_action = logAction state clientSend 97 | , GHC.ghcLink = GHC.NoLink 98 | , GHC.hscTarget = GHC.HscInterpreted 99 | } 100 | (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts) 101 | _ <- GHC.setSessionDynFlags finalDynFlags 102 | return () 103 | 104 | runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc () 105 | runCommand _ clientSend (CmdCheck file) = do 106 | let noPhase = Nothing 107 | target <- GHC.guessTarget file noPhase 108 | GHC.setTargets [target] 109 | let handler err = GHC.printException err >> return GHC.Failed 110 | flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) 111 | liftIO $ case flag of 112 | GHC.Succeeded -> clientSend (ClientExit ExitSuccess) 113 | GHC.Failed -> clientSend (ClientExit (ExitFailure 1)) 114 | runCommand _ clientSend (CmdModuleFile moduleName) = do 115 | modSummaries <- getModSummaries 116 | case find (moduleSummaryMatchesModuleName moduleName) modSummaries of 117 | Nothing -> 118 | liftIO $ mapM_ clientSend 119 | [ ClientStderr "Module not found" 120 | , ClientExit (ExitFailure 1) 121 | ] 122 | Just modSummary -> 123 | case GHC.ml_hs_file (GHC.ms_location modSummary) of 124 | Nothing -> 125 | liftIO $ mapM_ clientSend 126 | [ ClientStderr "Module does not have a source file" 127 | , ClientExit (ExitFailure 1) 128 | ] 129 | Just file -> 130 | liftIO $ mapM_ clientSend 131 | [ ClientStdout file 132 | , ClientExit ExitSuccess 133 | ] 134 | where 135 | moduleSummaryMatchesModuleName modName modSummary = 136 | modName == (GHC.moduleNameString . GHC.moduleName . GHC.ms_mod) modSummary 137 | runCommand state clientSend (CmdInfo file identifier) = do 138 | result <- withWarnings state False $ 139 | getIdentifierInfo file identifier 140 | case result of 141 | Left err -> 142 | liftIO $ mapM_ clientSend 143 | [ ClientStderr err 144 | , ClientExit (ExitFailure 1) 145 | ] 146 | Right info -> liftIO $ mapM_ clientSend 147 | [ ClientStdout info 148 | , ClientExit ExitSuccess 149 | ] 150 | runCommand state clientSend (CmdType file (line, col)) = do 151 | result <- withWarnings state False $ 152 | getType file (line, col) 153 | case result of 154 | Left err -> 155 | liftIO $ mapM_ clientSend 156 | [ ClientStderr err 157 | , ClientExit (ExitFailure 1) 158 | ] 159 | Right types -> liftIO $ do 160 | mapM_ (clientSend . ClientStdout . formatType) types 161 | clientSend (ClientExit ExitSuccess) 162 | where 163 | formatType :: ((Int, Int, Int, Int), String) -> String 164 | formatType ((startLine, startCol, endLine, endCol), t) = 165 | concat 166 | [ show startLine , " " 167 | , show startCol , " " 168 | , show endLine , " " 169 | , show endCol , " " 170 | , "\"", t, "\"" 171 | ] 172 | 173 | #if __GLASGOW_HASKELL__ >= 800 174 | logAction :: IORef State -> ClientSend -> GHC.DynFlags -> a -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () 175 | logAction state clientSend dflags _ severity srcspan style msg = 176 | let out = Outputable.renderWithStyle dflags fullMsg style 177 | _ = severity 178 | in logActionSend state clientSend severity out 179 | where fullMsg = ErrUtils.mkLocMessage severity srcspan msg 180 | #elif __GLASGOW_HASKELL__ >= 706 181 | logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () 182 | logAction state clientSend dflags severity srcspan style msg = 183 | let out = Outputable.renderWithStyle dflags fullMsg style 184 | _ = severity 185 | in logActionSend state clientSend severity out 186 | where fullMsg = ErrUtils.mkLocMessage severity srcspan msg 187 | #else 188 | logAction :: IORef State -> ClientSend -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.Message -> IO () 189 | logAction state clientSend severity srcspan style msg = 190 | let out = Outputable.renderWithStyle fullMsg style 191 | _ = severity 192 | in logActionSend state clientSend severity out 193 | where fullMsg = ErrUtils.mkLocMessage srcspan msg 194 | #endif 195 | 196 | logActionSend :: IORef State -> ClientSend -> GHC.Severity -> String -> IO () 197 | logActionSend state clientSend severity out = do 198 | currentState <- readIORef state 199 | when (not (isWarning severity) || stateWarningsEnabled currentState) $ 200 | clientSend (ClientStdout out) 201 | where 202 | isWarning :: GHC.Severity -> Bool 203 | isWarning GHC.SevWarning = True 204 | isWarning _ = False 205 | -------------------------------------------------------------------------------- /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/GhcTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GhcTypes 3 | ( getModSummaries 4 | , TypecheckI 5 | ) where 6 | 7 | import qualified GHC 8 | import qualified HscTypes 9 | #if __GLASGOW_HASKELL__ < 804 10 | import qualified Var 11 | #endif 12 | 13 | getModSummaries :: GHC.Ghc [GHC.ModSummary] 14 | #if __GLASGOW_HASKELL__ >= 804 15 | getModSummaries = HscTypes.mgModSummaries <$> GHC.getModuleGraph 16 | #else 17 | getModSummaries = GHC.getModuleGraph 18 | #endif 19 | 20 | #if __GLASGOW_HASKELL__ >= 804 21 | type TypecheckI = GHC.GhcTc 22 | #else 23 | type TypecheckI = Var.Var 24 | #endif 25 | -------------------------------------------------------------------------------- /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 | import GhcTypes (getModSummaries, TypecheckI) 33 | 34 | getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String) 35 | getIdentifierInfo file identifier = 36 | withModSummary file $ \m -> do 37 | #if __GLASGOW_HASKELL__ >= 706 38 | GHC.setContext [GHC.IIModule (GHC.moduleName (GHC.ms_mod m))] 39 | #elif __GLASGOW_HASKELL__ >= 704 40 | GHC.setContext [GHC.IIModule (GHC.ms_mod m)] 41 | #else 42 | GHC.setContext [GHC.ms_mod m] [] 43 | #endif 44 | GHC.handleSourceError (return . Left . show) $ 45 | liftM Right (infoThing identifier) 46 | 47 | getType :: FilePath -> (Int, Int) -> GHC.Ghc (Either String [((Int, Int, Int, Int), String)]) 48 | getType file (line, col) = 49 | withModSummary file $ \m -> do 50 | p <- GHC.parseModule m 51 | typechecked <- GHC.typecheckModule p 52 | types <- processTypeCheckedModule typechecked (line, col) 53 | return (Right types) 54 | 55 | withModSummary :: String -> (HscTypes.ModSummary -> GHC.Ghc (Either String a)) -> GHC.Ghc (Either String a) 56 | withModSummary file action = do 57 | let noPhase = Nothing 58 | target <- GHC.guessTarget file noPhase 59 | GHC.setTargets [target] 60 | 61 | let handler err = GHC.printException err >> return GHC.Failed 62 | flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) 63 | case flag of 64 | GHC.Failed -> return (Left "Error loading targets") 65 | GHC.Succeeded -> do 66 | modSummary <- getModuleSummary file 67 | case modSummary of 68 | Nothing -> return (Left "Module not found in module graph") 69 | Just m -> action m 70 | 71 | getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary) 72 | getModuleSummary file = do 73 | modSummaries <- getModSummaries 74 | case find (moduleSummaryMatchesFilePath file) modSummaries of 75 | Nothing -> return Nothing 76 | Just moduleSummary -> return (Just moduleSummary) 77 | 78 | moduleSummaryMatchesFilePath :: FilePath -> GHC.ModSummary -> Bool 79 | moduleSummaryMatchesFilePath file moduleSummary = 80 | let location = GHC.ms_location moduleSummary 81 | location_file = GHC.ml_hs_file location 82 | in case location_file of 83 | Just f -> f == file 84 | Nothing -> False 85 | 86 | ------------------------------------------------------------------------------ 87 | -- Most of the following code was taken from the source code of 'ghc-mod' (with 88 | -- some stylistic changes) 89 | -- 90 | -- ghc-mod: 91 | -- http://www.mew.org/~kazu/proj/ghc-mod/ 92 | -- https://github.com/kazu-yamamoto/ghc-mod/ 93 | 94 | processTypeCheckedModule :: GHC.TypecheckedModule -> (Int, Int) -> GHC.Ghc [((Int, Int, Int, Int), String)] 95 | processTypeCheckedModule tcm (line, col) = do 96 | let tcs = GHC.tm_typechecked_source tcm 97 | bs = listifySpans tcs (line, col) :: [GHC.LHsBind TypecheckI] 98 | es = listifySpans tcs (line, col) :: [GHC.LHsExpr TypecheckI] 99 | ps = listifySpans tcs (line, col) :: [GHC.LPat TypecheckI] 100 | bts <- mapM (getTypeLHsBind tcm) bs 101 | ets <- mapM (getTypeLHsExpr tcm) es 102 | pts <- mapM (getTypeLPat tcm) ps 103 | #if __GLASGOW_HASKELL__ >= 706 104 | dflags <- DynFlags.getDynFlags 105 | return $ map (toTup dflags) $ 106 | #else 107 | return $ map toTup $ 108 | #endif 109 | sortBy cmp $ catMaybes $ concat [ets, bts, pts] 110 | where 111 | cmp (a, _) (b, _) 112 | | a `GHC.isSubspanOf` b = LT 113 | | b `GHC.isSubspanOf` a = GT 114 | | otherwise = EQ 115 | 116 | #if __GLASGOW_HASKELL__ >= 706 117 | toTup :: GHC.DynFlags -> (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) 118 | toTup dflags (spn, typ) = (fourInts spn, pretty dflags typ) 119 | #else 120 | toTup :: (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) 121 | toTup (spn, typ) = (fourInts spn, pretty typ) 122 | #endif 123 | 124 | fourInts :: GHC.SrcSpan -> (Int, Int, Int, Int) 125 | fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan 126 | 127 | getSrcSpan :: GHC.SrcSpan -> Maybe (Int, Int, Int, Int) 128 | getSrcSpan (GHC.RealSrcSpan spn) = 129 | Just (GHC.srcSpanStartLine spn 130 | , GHC.srcSpanStartCol spn 131 | , GHC.srcSpanEndLine spn 132 | , GHC.srcSpanEndCol spn) 133 | getSrcSpan _ = Nothing 134 | 135 | getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind TypecheckI -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) 136 | #if __GLASGOW_HASKELL__ >= 806 137 | getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty $ HsExpr.mg_ext grp) 138 | #elif __GLASGOW_HASKELL__ >= 708 139 | getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty grp) 140 | #else 141 | getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) 142 | #endif 143 | getTypeLHsBind _ _ = return Nothing 144 | 145 | getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr TypecheckI -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) 146 | #if __GLASGOW_HASKELL__ >= 708 147 | getTypeLHsExpr _ e = do 148 | #else 149 | getTypeLHsExpr tcm e = do 150 | #endif 151 | hs_env <- GHC.getSession 152 | #if __GLASGOW_HASKELL__ >= 708 153 | (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e 154 | #else 155 | let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm 156 | rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm 157 | ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm 158 | (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e 159 | #endif 160 | return () 161 | case mbe of 162 | Nothing -> return Nothing 163 | Just expr -> return $ Just (GHC.getLoc e, CoreUtils.exprType expr) 164 | 165 | getTypeLPat :: GHC.TypecheckedModule -> GHC.LPat TypecheckI -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) 166 | getTypeLPat _ (GHC.L spn pat) = return $ Just (spn, TcHsSyn.hsPatType pat) 167 | 168 | listifySpans :: Typeable a => GHC.TypecheckedSource -> (Int, Int) -> [GHC.Located a] 169 | listifySpans tcs lc = listifyStaged TypeChecker p tcs 170 | where 171 | p (GHC.L spn _) = GHC.isGoodSrcSpan spn && spn `GHC.spans` lc 172 | 173 | listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] 174 | listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) 175 | 176 | #if __GLASGOW_HASKELL__ >= 706 177 | pretty :: GHC.DynFlags -> GHC.Type -> String 178 | pretty dflags = 179 | #else 180 | pretty :: GHC.Type -> String 181 | pretty = 182 | #endif 183 | #if __GLASGOW_HASKELL__ >= 800 184 | Pretty.renderStyle Pretty.style 185 | { Pretty.lineLength = 0 186 | , Pretty.mode = Pretty.OneLineMode 187 | } 188 | #elif __GLASGOW_HASKELL__ >= 708 189 | Pretty.showDoc Pretty.OneLineMode 0 190 | #else 191 | Pretty.showDocWith Pretty.OneLineMode 192 | #endif 193 | #if __GLASGOW_HASKELL__ >= 706 194 | . Outputable.withPprStyleDoc dflags 195 | #else 196 | . Outputable.withPprStyleDoc 197 | #endif 198 | #if __GLASGOW_HASKELL__ >= 802 199 | (Outputable.mkUserStyle dflags Outputable.neverQualify Outputable.AllTheWay) 200 | #else 201 | (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) 202 | #endif 203 | #if __GLASGOW_HASKELL__ >= 708 204 | . PprTyThing.pprTypeForUser 205 | #else 206 | . PprTyThing.pprTypeForUser False 207 | #endif 208 | 209 | ------------------------------------------------------------------------------ 210 | -- The following was taken from 'ghc-syb-utils' 211 | -- 212 | -- ghc-syb-utils: 213 | -- https://github.com/nominolo/ghc-syb 214 | 215 | -- | Ghc Ast types tend to have undefined holes, to be filled 216 | -- by later compiler phases. We tag Asts with their source, 217 | -- so that we can avoid such holes based on who generated the Asts. 218 | data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show) 219 | 220 | -- | Like 'everything', but avoid known potholes, based on the 'Stage' that 221 | -- generated the Ast. 222 | everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r 223 | everythingStaged stage k z f x 224 | | (const False `extQ` 225 | #if __GLASGOW_HASKELL__ < 806 226 | postTcType `extQ` 227 | #endif 228 | fixity `extQ` nameSet) x = z 229 | | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) 230 | where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool 231 | #if __GLASGOW_HASKELL__ >= 806 232 | #elif __GLASGOW_HASKELL__ >= 710 233 | postTcType = const (stage Bool 234 | #else 235 | postTcType = const (stage Bool 236 | #endif 237 | fixity = const (stage Bool 238 | 239 | ------------------------------------------------------------------------------ 240 | -- The following code was taken from GHC's ghc/InteractiveUI.hs (with some 241 | -- stylistic changes) 242 | 243 | infoThing :: String -> GHC.Ghc String 244 | infoThing str = do 245 | names <- GHC.parseName str 246 | #if __GLASGOW_HASKELL__ >= 804 247 | mb_stuffs <- mapM (GHC.getInfo False) names 248 | let filtered = filterOutChildren (\(t,_f,_i,_,_) -> t) (catMaybes mb_stuffs) 249 | #elif __GLASGOW_HASKELL__ >= 708 250 | mb_stuffs <- mapM (GHC.getInfo False) names 251 | let filtered = filterOutChildren (\(t,_f,_i,_) -> t) (catMaybes mb_stuffs) 252 | #else 253 | mb_stuffs <- mapM GHC.getInfo names 254 | let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) 255 | #endif 256 | unqual <- GHC.getPrintUnqual 257 | #if __GLASGOW_HASKELL__ >= 706 258 | dflags <- DynFlags.getDynFlags 259 | return $ Outputable.showSDocForUser dflags unqual $ 260 | #else 261 | return $ Outputable.showSDocForUser unqual $ 262 | #endif 263 | #if __GLASGOW_HASKELL__ >= 708 264 | Outputable.vcat (intersperse (Outputable.text "") $ map pprInfo filtered) 265 | #else 266 | Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) 267 | #endif 268 | 269 | -- Filter out names whose parent is also there Good 270 | -- example is '[]', which is both a type and data 271 | -- constructor in the same type 272 | filterOutChildren :: (a -> HscTypes.TyThing) -> [a] -> [a] 273 | filterOutChildren get_thing xs 274 | = filter (not . has_parent) xs 275 | where 276 | all_names = NameSet.mkNameSet (map (GHC.getName . get_thing) xs) 277 | #if __GLASGOW_HASKELL__ >= 704 278 | has_parent x = case HscTypes.tyThingParent_maybe (get_thing x) of 279 | #else 280 | has_parent x = case PprTyThing.pprTyThingParent_maybe (get_thing x) of 281 | #endif 282 | Just p -> GHC.getName p `NameSet.elemNameSet` all_names 283 | Nothing -> False 284 | 285 | #if __GLASGOW_HASKELL__ >= 804 286 | pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst], Outputable.SDoc) -> Outputable.SDoc 287 | pprInfo (thing, fixity, insts, _, _) = 288 | PprTyThing.pprTyThingInContextLoc thing 289 | #elif __GLASGOW_HASKELL__ >= 708 290 | pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst]) -> Outputable.SDoc 291 | pprInfo (thing, fixity, insts, _) = 292 | PprTyThing.pprTyThingInContextLoc thing 293 | #elif __GLASGOW_HASKELL__ >= 706 294 | pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc 295 | pprInfo pefas (thing, fixity, insts) = 296 | PprTyThing.pprTyThingInContextLoc pefas thing 297 | #else 298 | pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc 299 | pprInfo pefas (thing, fixity, insts) = 300 | PprTyThing.pprTyThingInContextLoc pefas thing 301 | #endif 302 | Outputable.$$ show_fixity fixity 303 | Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) 304 | where 305 | show_fixity fix 306 | | fix == GHC.defaultFixity = Outputable.empty 307 | | otherwise = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing) 308 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment (getProgName) 4 | import System.IO (hPutStrLn, stderr) 5 | 6 | import Client (getServerStatus, serverCommand, stopServer) 7 | import CommandArgs 8 | import Daemonize (daemonize) 9 | import Server (startServer, createListenSocket) 10 | import Types (Command(..)) 11 | 12 | defaultSocketFilename :: FilePath 13 | defaultSocketFilename = ".hdevtools.sock" 14 | 15 | getSocketFilename :: Maybe FilePath -> FilePath 16 | getSocketFilename Nothing = defaultSocketFilename 17 | getSocketFilename (Just f) = f 18 | 19 | main :: IO () 20 | main = do 21 | args <- loadHDevTools 22 | let sock = getSocketFilename (socket args) 23 | case args of 24 | Admin {} -> doAdmin sock args 25 | Check {} -> doCheck sock args 26 | ModuleFile {} -> doModuleFile sock args 27 | Info {} -> doInfo sock args 28 | Type {} -> doType sock args 29 | 30 | doAdmin :: FilePath -> HDevTools -> IO () 31 | doAdmin sock args 32 | | start_server args = 33 | if noDaemon args then startServer sock Nothing 34 | else do 35 | s <- createListenSocket sock 36 | daemonize True $ startServer sock (Just s) 37 | | status args = getServerStatus sock 38 | | stop_server args = stopServer sock 39 | | otherwise = do 40 | progName <- getProgName 41 | hPutStrLn stderr "You must provide a command. See:" 42 | hPutStrLn stderr $ progName ++ " --help" 43 | 44 | doModuleFile :: FilePath -> HDevTools -> IO () 45 | doModuleFile sock args = 46 | serverCommand sock (CmdModuleFile (module_ args)) (ghcOpts args) 47 | 48 | doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> IO () 49 | doFileCommand cmdName cmd sock args 50 | | null (file args) = do 51 | progName <- getProgName 52 | hPutStrLn stderr "You must provide a haskell source file. See:" 53 | hPutStrLn stderr $ progName ++ " " ++ cmdName ++ " --help" 54 | | otherwise = serverCommand sock (cmd args) (ghcOpts args) 55 | 56 | doCheck :: FilePath -> HDevTools -> IO () 57 | doCheck = doFileCommand "check" $ 58 | \args -> CmdCheck (file args) 59 | 60 | doInfo :: FilePath -> HDevTools -> IO () 61 | doInfo = doFileCommand "info" $ 62 | \args -> CmdInfo (file args) (identifier args) 63 | 64 | doType :: FilePath -> HDevTools -> IO () 65 | doType = doFileCommand "type" $ 66 | \args -> CmdType (file args) (line args, col args) 67 | -------------------------------------------------------------------------------- /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, isDoesNotExistError) 12 | 13 | import CommandLoop (newCommandLoopState, startCommandLoop) 14 | import Types (ClientDirective(..), Command, ServerDirective(..)) 15 | import Util (readMaybe) 16 | 17 | createListenSocket :: FilePath -> IO Socket 18 | createListenSocket socketPath = 19 | listenOn (UnixSocket socketPath) 20 | 21 | startServer :: FilePath -> Maybe Socket -> IO () 22 | startServer socketPath mbSock = do 23 | case mbSock of 24 | Nothing -> bracket (createListenSocket socketPath) cleanup go 25 | Just sock -> (go sock) `finally` (cleanup sock) 26 | where 27 | cleanup :: Socket -> IO () 28 | cleanup sock = do 29 | sClose sock 30 | removeSocketFile 31 | 32 | go :: Socket -> IO () 33 | go sock = do 34 | state <- newCommandLoopState 35 | currentClient <- newIORef Nothing 36 | startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing 37 | 38 | removeSocketFile :: IO () 39 | removeSocketFile = do 40 | -- Ignore possible error if socket file does not exist 41 | _ <- tryJust (guard . isDoesNotExistError) $ removeFile socketPath 42 | return () 43 | 44 | clientSend :: IORef (Maybe Handle) -> ClientDirective -> IO () 45 | clientSend currentClient clientDirective = do 46 | mbH <- readIORef currentClient 47 | case mbH of 48 | Just h -> ignoreEPipe $ do 49 | hPutStrLn h (show clientDirective) 50 | hFlush h 51 | Nothing -> error "This is impossible" 52 | where 53 | -- EPIPE means that the client is no longer there. 54 | ignoreEPipe = handleJust (guard . isEPipe) (const $ return ()) 55 | isEPipe = (==ResourceVanished) . ioeGetErrorType 56 | 57 | getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, [String])) 58 | getNextCommand currentClient sock = do 59 | checkCurrent <- readIORef currentClient 60 | case checkCurrent of 61 | Just h -> hClose h 62 | Nothing -> return () 63 | (h, _, _) <- accept sock 64 | writeIORef currentClient (Just h) 65 | msg <- hGetLine h -- TODO catch exception 66 | let serverDirective = readMaybe msg 67 | case serverDirective of 68 | Nothing -> do 69 | clientSend currentClient $ ClientUnexpectedError $ 70 | "The client sent an invalid message to the server: " ++ show msg 71 | getNextCommand currentClient sock 72 | Just (SrvCommand cmd ghcOpts) -> do 73 | return $ Just (cmd, ghcOpts) 74 | Just SrvStatus -> do 75 | mapM_ (clientSend currentClient) $ 76 | [ ClientStdout "Server is running." 77 | , ClientExit ExitSuccess 78 | ] 79 | getNextCommand currentClient sock 80 | Just SrvExit -> do 81 | mapM_ (clientSend currentClient) $ 82 | [ ClientStdout "Shutting down server." 83 | , ClientExit ExitSuccess 84 | ] 85 | -- Must close the handle here because we are exiting the loop so it 86 | -- won't be closed in the code above 87 | hClose h 88 | return Nothing 89 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types 2 | ( ServerDirective(..) 3 | , ClientDirective(..) 4 | , Command(..) 5 | ) where 6 | 7 | import System.Exit (ExitCode) 8 | 9 | data ServerDirective 10 | = SrvCommand Command [String] 11 | | SrvStatus 12 | | SrvExit 13 | deriving (Read, Show) 14 | 15 | data ClientDirective 16 | = ClientStdout String 17 | | ClientStderr String 18 | | ClientExit ExitCode 19 | | ClientUnexpectedError String -- ^ For unexpected errors that should not happen 20 | deriving (Read, Show) 21 | 22 | data Command 23 | = CmdCheck FilePath 24 | | CmdModuleFile String 25 | | CmdInfo FilePath String 26 | | CmdType FilePath (Int, Int) 27 | deriving (Read, Show) 28 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------