pax_global_header00006660000000000000000000000064120674364160014523gustar00rootroot0000000000000052 comment=59a762483cf182d0162b7fa9c01b604e27b7a920 hdevtools-0.1.0.5/000077500000000000000000000000001206743641600136735ustar00rootroot00000000000000hdevtools-0.1.0.5/AUTHORS000066400000000000000000000000431206743641600147400ustar00rootroot00000000000000Bit Connor hdevtools-0.1.0.5/LICENSE000066400000000000000000000020741206743641600147030ustar00rootroot00000000000000Copyright (C) 2012 The hdevtools Authors (see AUTHORS file) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hdevtools-0.1.0.5/README.md000066400000000000000000000144021206743641600151530ustar00rootroot00000000000000hdevtools ========= Persistent GHC powered background server for FAST Haskell development tools About ----- `hdevtools` is a backend for text editor plugins, to allow for things such as syntax and type checking of Haskell code, and retrieving type information, all directly from within your text editor. The advantage that `hdevtools` has over competitors, is that it runs silently in a persistent background process, and therefore is able to keeps all of your Haskell modules and dependent libraries loaded in memory. This way, when you change only a single source file, only it needs to be reloaded and rechecked, instead of having to reload everything. This makes `hdevtools` very fast for checking syntax and type errors (runs just as fast as the `:reload` command in GHCi). In fact, syntax and type checking is so fast, that you can safely enable auto checking on every save. Even for huge projects, checking is nearly instant. Once you start using `hdevtools` and you get used to having your errors shown to you instantly (without having to switch back and forth between GHCi and your editor), and shown directly on your code, in your editor (without having to wait forever for GHC to run) you will wonder how you ever lived without it. In addition to checking Haskell source code for errors, `hdevtools` has tools for getting info about identifiers, and getting type information for snippets of code. Text Editor Integration ----------------------- `hdevtools` is designed to be integrated into text editors. The list of current editor plugins that supply this integration is below. But before you do anything, you must first install `hdevtools` itself. The easiest way is from [Hackage][1] via cabal install: $ cabal install hdevtools Then you should install one or more of the following editor plugins: ### Vim - [Syntastic][2] ### [Syntastic][2] is a popular syntax checking plugin for Vim, and is the recommended Vim integration of `hdevtools` syntax and type checking. Recent versions of Syntastic(since Sep. 2012) have builtin support for `hdevtools`. Simply install `hdevtools` (as above) and [Syntastic][2], and it will automatically check your Haskell files. [Syntastic][2] will respect the `g:hdevtools_options` variable (the same one as used by [vim-hdevtools][3], see below). See the section "Specifying GHC Options" below for details how to use it. ### Vim - [vim-hdevtools][3] ### In addition to Syntastic, it is recommended that you also use [`vim-hdevtools`][3] for additional functionality. [`vim-hdevtools`][3] offers integration with the rest of the `hdevtools` tools, including retrieving info about the identifier under the cursor, and getting the type of the code under the cursor. Refer to its documentation for more details. ### Emacs ### I encourage the community to develop integration plugins for Emacs and other editors. In the mean time, please see the manual integration information below. ### Manual Editor Integration for any Editor ### Most editors allow you to run a `make` command, and will then parse the output for errors and show line numbers, allowing you to jump between errors. The `hdevtools check` command is suitable for such usage. For example, in Vim something like this will work: :let &makeprg='hdevtools check %' (Vim will replace the `%` character with the name of the current file). Then you can run :make And Vim will invoke `hdevtools` to check the current file for errors, and then show a list of them and allow jumping to them. See the "Command Line Usage" section below for more information. Command Line Usage ------------------ Note: When using one of the above editor plugins, you don't really need to know this. ### Available Commands and Help ### For the list of commands available, run: $ hdevtools --help To get help for a specific command, run: $ hdevtools [COMMAND] --help For example: $ hdevtools check --help ### The `hdevtools` background process ### The first time `hdevtools` runs a command, it will spawn a background process that will remain running forever. You can check the status of this background process by running: $ hdevtools --status You can shutdown the background process by running: $ hdevtools --stop-server Communication with the background process is done through a unix socket file. The default name is `.hdevtools.sock`, in the current directory. This allows you to use `hdevtools` with multiple projects simultaneously, without the background processes getting in the way of each other. You can use a different socket file name with the `--socket` option, which should be used for each invocation of `hdevtools`. Remember that when telling `hdevtools` to check a Haskell file, paths are relative to the path of the background process, not your current directory. This can cause problems, and therefore it is recommended that you leave the socket file as the default, and always run `hdevtools` from the same directory. ### Specifying GHC Options ### For most non-trivial projects, you will need to tell `hdevtools` about additional GHC options that your project requires. All `hdevtools` commands accept a `-g` flag for this purpose. For example: * Your project source code is in the directory `src` * You want to use the GHC option `-Wall` * You want to hide the package `transformers` to prevent conflicts Invoke `hdevtools` with something like this: $ hdevtools check -g -isrc -g -Wall -g -hide-package -g transformers Foo.hs Notice that a `-g` flag is inserted before each GHC option. Don't try to string multiple GHC options together after a single `-g` flag: This won't work: $ hdevtools check -g '-hide-package transformers' Foo.hs The Vim plugins allow setting GHC options in the `g:hdevtools_options` variable. For example, for the above project, put the following in your `.vimrc`: let g:hdevtools_options = '-g -isrc -g -Wall -g -hide-package -g transformers' In general, you will need to pass to `hdevtools` the same GHC options that you would pass to GHCi. Credits ------- `hdevtools` was inspired by [ghcmod][4], but has the advantage that due to its client-server architecture it is much faster. [1]: http://hackage.haskell.org/package/hdevtools [2]: https://github.com/scrooloose/syntastic [3]: https://github.com/bitc/vim-hdevtools [4]: http://www.mew.org/~kazu/proj/ghc-mod/en/ hdevtools-0.1.0.5/Setup.hs000066400000000000000000000000561206743641600153300ustar00rootroot00000000000000import Distribution.Simple main = defaultMain hdevtools-0.1.0.5/hdevtools.cabal000066400000000000000000000053751206743641600167000ustar00rootroot00000000000000name: hdevtools version: 0.1.0.5 synopsis: Persistent GHC powered background server for FAST haskell development tools description: 'hdevtools' is a backend for text editor plugins, to allow for things such as syntax and type checking of Haskell code, and retrieving type information, all directly from within your text editor. . The advantage that 'hdevtools' has over competitors, is that it runs silently in a persistent background process, and therefore is able to keeps all of your Haskell modules and dependent libraries loaded in memory. This way, when you change only a single source file, only it needs to be reloaded and rechecked, instead of having to reload everything. . This makes 'hdevtools' very fast for checking syntax and type errors (runs just as fast as the ':reload' command in GHCi). . In fact, syntax and type checking is so fast, that you can safely enable auto checking on every save. Even for huge projects, checking is nearly instant. . Once you start using 'hdevtools' and you get used to having your errors shown to you instantly (without having to switch back and forth between GHCi and your editor), and shown directly on your code, in your editor (without having to wait forever for GHC to run) you will wonder how you ever lived without it. . In addition to checking Haskell source code for errors, 'hdevtools' has tools for getting info about identifiers, and getting type information for snippets of code. license: MIT license-file: LICENSE author: Bit Connor maintainer: mutantlemon@gmail.com copyright: See AUTHORS file category: Development homepage: https://github.com/bitc/hdevtools/ bug-reports: https://github.com/bitc/hdevtools/issues/ build-type: Simple cabal-version: >=1.8 source-repository head type: git location: git://github.com/bitc/hdevtools.git executable hdevtools hs-source-dirs: src ghc-options: -Wall cpp-options: -DCABAL main-is: Main.hs other-modules: Client, CommandArgs, CommandLoop, Daemonize, Info, Main, Server, Types, Util, Paths_hdevtools build-depends: base == 4.*, cmdargs, directory, ghc >= 7.2, ghc-paths, syb, network, time, unix hdevtools-0.1.0.5/src/000077500000000000000000000000001206743641600144625ustar00rootroot00000000000000hdevtools-0.1.0.5/src/Client.hs000066400000000000000000000042121206743641600162330ustar00rootroot00000000000000module Client ( getServerStatus , stopServer , serverCommand ) where import Control.Exception (tryJust) import Control.Monad (guard) import Network (PortID(UnixSocket), connectTo) import System.Exit (exitFailure, exitWith) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) import Daemonize (daemonize) import Server (createListenSocket, startServer) import Types (ClientDirective(..), Command(..), ServerDirective(..)) import Util (readMaybe) connect :: FilePath -> IO Handle connect sock = do connectTo "" (UnixSocket sock) getServerStatus :: FilePath -> IO () getServerStatus sock = do h <- connect sock hPutStrLn h $ show SrvStatus hFlush h startClientReadLoop h stopServer :: FilePath -> IO () stopServer sock = do h <- connect sock hPutStrLn h $ show SrvExit hFlush h startClientReadLoop h serverCommand :: FilePath -> Command -> [String] -> IO () serverCommand sock cmd ghcOpts = do r <- tryJust (guard . isDoesNotExistError) (connect sock) case r of Right h -> do hPutStrLn h $ show (SrvCommand cmd ghcOpts) hFlush h startClientReadLoop h Left _ -> do s <- createListenSocket sock daemonize False $ startServer sock (Just s) serverCommand sock cmd ghcOpts startClientReadLoop :: Handle -> IO () startClientReadLoop h = do msg <- hGetLine h let clientDirective = readMaybe msg case clientDirective of Just (ClientStdout out) -> putStrLn out >> startClientReadLoop h Just (ClientStderr err) -> hPutStrLn stderr err >> startClientReadLoop h Just (ClientExit exitCode) -> hClose h >> exitWith exitCode Just (ClientUnexpectedError err) -> hClose h >> unexpectedError err Nothing -> do hClose h unexpectedError $ "The server sent an invalid message to the client: " ++ show msg unexpectedError :: String -> IO () unexpectedError err = do hPutStrLn stderr banner hPutStrLn stderr err hPutStrLn stderr banner exitFailure where banner = replicate 78 '*' hdevtools-0.1.0.5/src/CommandArgs.hs000066400000000000000000000102621206743641600172120ustar00rootroot00000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} module CommandArgs ( HDevTools(..) , loadHDevTools ) where import System.Console.CmdArgs.Implicit import System.Environment (getProgName) import System.Info (arch, os) import qualified Config #ifdef CABAL import Data.Version (showVersion) import Paths_hdevtools (version) #endif programVersion :: String programVersion = #ifdef CABAL "version " ++ showVersion version #else "unknown-version (not built with cabal)" #endif fullVersion :: String fullVersion = concat [ programVersion , " (ghc-", Config.cProjectVersion, "-", arch, "-", os, ")" ] data HDevTools = Admin { socket :: Maybe FilePath , start_server :: Bool , noDaemon :: Bool , status :: Bool , stop_server :: Bool } | Check { socket :: Maybe FilePath , ghcOpts :: [String] , file :: String } | ModuleFile { socket :: Maybe FilePath , ghcOpts :: [String] , module_ :: String } | Info { socket :: Maybe FilePath , ghcOpts :: [String] , file :: String , identifier :: String } | Type { socket :: Maybe FilePath , ghcOpts :: [String] , file :: String , line :: Int , col :: Int } deriving (Show, Data, Typeable) dummyAdmin :: HDevTools dummyAdmin = Admin { socket = Nothing , start_server = False , noDaemon = False , status = False , stop_server = False } dummyCheck :: HDevTools dummyCheck = Check { socket = Nothing , ghcOpts = [] , file = "" } dummyModuleFile :: HDevTools dummyModuleFile = ModuleFile { socket = Nothing , ghcOpts = [] , module_ = "" } dummyInfo :: HDevTools dummyInfo = Info { socket = Nothing , ghcOpts = [] , file = "" , identifier = "" } dummyType :: HDevTools dummyType = Type { socket = Nothing , ghcOpts = [] , file = "" , line = 0 , col = 0 } admin :: Annotate Ann admin = record dummyAdmin [ socket := def += typFile += help "socket file to use" , start_server := def += help "start server" , noDaemon := def += help "do not daemonize (only if --start-server)" , status := def += help "show status of server" , stop_server := def += help "shutdown the server" ] += help "Interactions with the server" check :: Annotate Ann check = record dummyCheck [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options" , file := def += typFile += argPos 0 += opt "" ] += help "Check a haskell source file for errors and warnings" moduleFile :: Annotate Ann moduleFile = record dummyModuleFile [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options" , module_ := def += typ "MODULE" += argPos 0 ] += help "Get the haskell source file corresponding to a module name" info :: Annotate Ann info = record dummyInfo [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options" , file := def += typFile += argPos 0 += opt "" , identifier := def += typ "IDENTIFIER" += argPos 1 ] += help "Get info from GHC about the specified identifier" type_ :: Annotate Ann type_ = record dummyType [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options" , file := def += typFile += argPos 0 += opt "" , line := def += typ "LINE" += argPos 1 , col := def += typ "COLUMN" += argPos 2 ] += help "Get the type of the expression at the specified line and column" full :: String -> Annotate Ann full progName = modes_ [admin += auto, check, moduleFile, info, type_] += helpArg [name "h", groupname "Help"] += versionArg [groupname "Help"] += program progName += summary (progName ++ ": " ++ fullVersion) loadHDevTools :: IO HDevTools loadHDevTools = do progName <- getProgName (cmdArgs_ (full progName) :: IO HDevTools) hdevtools-0.1.0.5/src/CommandLoop.hs000066400000000000000000000164521206743641600172360ustar00rootroot00000000000000{-# LANGUAGE CPP #-} module CommandLoop ( newCommandLoopState , startCommandLoop ) where import Control.Monad (when) import Data.IORef import Data.List (find) import MonadUtils (MonadIO, liftIO) import System.Exit (ExitCode(ExitFailure, ExitSuccess)) import qualified ErrUtils import qualified Exception (ExceptionMonad) import qualified GHC import qualified GHC.Paths import qualified Outputable import Types (ClientDirective(..), Command(..)) import Info (getIdentifierInfo, getType) type CommandObj = (Command, [String]) type ClientSend = ClientDirective -> IO () data State = State { stateWarningsEnabled :: Bool } newCommandLoopState :: IO (IORef State) newCommandLoopState = do newIORef $ State { stateWarningsEnabled = True } withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a withWarnings state warningsValue action = do beforeState <- liftIO $ getWarnings liftIO $ setWarnings warningsValue action `GHC.gfinally` (liftIO $ setWarnings beforeState) where getWarnings :: IO Bool getWarnings = readIORef state >>= return . stateWarningsEnabled setWarnings :: Bool -> IO () setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val } startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO () startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do continue <- GHC.runGhc (Just GHC.Paths.libdir) $ do configOk <- GHC.gcatch (configSession state clientSend initialGhcOpts >> return True) handleConfigError if configOk then do doMaybe mbInitial $ \cmd -> sendErrors (runCommand state clientSend cmd) processNextCommand False else processNextCommand True case continue of Nothing -> -- Exit return () Just (cmd, ghcOpts) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just cmd) where processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) processNextCommand forceReconfig = do mbNextCmd <- liftIO getNextCommand case mbNextCmd of Nothing -> -- Exit return Nothing Just (cmd, ghcOpts) -> if forceReconfig || (ghcOpts /= initialGhcOpts) then return (Just (cmd, ghcOpts)) else sendErrors (runCommand state clientSend cmd) >> processNextCommand False sendErrors :: GHC.Ghc () -> GHC.Ghc () sendErrors action = GHC.gcatch action (\x -> handleConfigError x >> return ()) handleConfigError :: GHC.GhcException -> GHC.Ghc Bool handleConfigError e = do liftIO $ mapM_ clientSend [ ClientStderr (GHC.showGhcException e "") , ClientExit (ExitFailure 1) ] return False doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () doMaybe Nothing _ = return () doMaybe (Just x) f = f x configSession :: IORef State -> ClientSend -> [String] -> GHC.Ghc () configSession state clientSend ghcOpts = do initialDynFlags <- GHC.getSessionDynFlags let updatedDynFlags = initialDynFlags { GHC.log_action = logAction state clientSend , GHC.ghcLink = GHC.NoLink , GHC.hscTarget = GHC.HscInterpreted } (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts) _ <- GHC.setSessionDynFlags finalDynFlags return () runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc () runCommand _ clientSend (CmdCheck file) = do let noPhase = Nothing target <- GHC.guessTarget file noPhase GHC.setTargets [target] let handler err = GHC.printException err >> return GHC.Failed flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) liftIO $ case flag of GHC.Succeeded -> clientSend (ClientExit ExitSuccess) GHC.Failed -> clientSend (ClientExit (ExitFailure 1)) runCommand _ clientSend (CmdModuleFile moduleName) = do moduleGraph <- GHC.getModuleGraph case find (moduleSummaryMatchesModuleName moduleName) moduleGraph of Nothing -> liftIO $ mapM_ clientSend [ ClientStderr "Module not found" , ClientExit (ExitFailure 1) ] Just modSummary -> case GHC.ml_hs_file (GHC.ms_location modSummary) of Nothing -> liftIO $ mapM_ clientSend [ ClientStderr "Module does not have a source file" , ClientExit (ExitFailure 1) ] Just file -> liftIO $ mapM_ clientSend [ ClientStdout file , ClientExit ExitSuccess ] where moduleSummaryMatchesModuleName modName modSummary = modName == (GHC.moduleNameString . GHC.moduleName . GHC.ms_mod) modSummary runCommand state clientSend (CmdInfo file identifier) = do result <- withWarnings state False $ getIdentifierInfo file identifier case result of Left err -> liftIO $ mapM_ clientSend [ ClientStderr err , ClientExit (ExitFailure 1) ] Right info -> liftIO $ mapM_ clientSend [ ClientStdout info , ClientExit ExitSuccess ] runCommand state clientSend (CmdType file (line, col)) = do result <- withWarnings state False $ getType file (line, col) case result of Left err -> liftIO $ mapM_ clientSend [ ClientStderr err , ClientExit (ExitFailure 1) ] Right types -> liftIO $ do mapM_ (clientSend . ClientStdout . formatType) types clientSend (ClientExit ExitSuccess) where formatType :: ((Int, Int, Int, Int), String) -> String formatType ((startLine, startCol, endLine, endCol), t) = concat [ show startLine , " " , show startCol , " " , show endLine , " " , show endCol , " " , "\"", t, "\"" ] #if __GLASGOW_HASKELL__ >= 706 logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () logAction state clientSend dflags severity srcspan style msg = let out = Outputable.renderWithStyle dflags fullMsg style _ = severity in logActionSend state clientSend severity out where fullMsg = ErrUtils.mkLocMessage severity srcspan msg #else logAction :: IORef State -> ClientSend -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.Message -> IO () logAction state clientSend severity srcspan style msg = let out = Outputable.renderWithStyle fullMsg style _ = severity in logActionSend state clientSend severity out where fullMsg = ErrUtils.mkLocMessage srcspan msg #endif logActionSend :: IORef State -> ClientSend -> GHC.Severity -> String -> IO () logActionSend state clientSend severity out = do currentState <- readIORef state when (not (isWarning severity) || stateWarningsEnabled currentState) $ clientSend (ClientStdout out) where isWarning :: GHC.Severity -> Bool isWarning GHC.SevWarning = True isWarning _ = False hdevtools-0.1.0.5/src/Daemonize.hs000066400000000000000000000016101206743641600167270ustar00rootroot00000000000000module Daemonize ( daemonize ) where import Control.Monad (when) import System.Exit (ExitCode(ExitSuccess)) import System.Posix.Process (exitImmediately, createSession, forkProcess) import System.Posix.IO -- | This goes against the common daemon guidelines and does not change the -- current working directory! -- -- We need the daemon to stay in the current directory for the GHC API to work daemonize :: Bool -> IO () -> IO () daemonize exit program = do _ <- forkProcess child1 when exit $ exitImmediately ExitSuccess where child1 = do _ <- createSession _ <- forkProcess child2 exitImmediately ExitSuccess child2 = do mapM_ closeFd [stdInput, stdOutput, stdError] nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] closeFd nullFd program hdevtools-0.1.0.5/src/Info.hs000066400000000000000000000222161206743641600157140ustar00rootroot00000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} module Info ( getIdentifierInfo , getType ) where import Control.Monad (liftM) import Data.Generics (GenericQ, mkQ, extQ, gmapQ) import Data.List (find, sortBy, intersperse) import Data.Maybe (catMaybes, fromMaybe) import Data.Typeable (Typeable) import MonadUtils (liftIO) import qualified CoreUtils import qualified Desugar #if __GLASGOW_HASKELL__ >= 706 import qualified DynFlags #endif import qualified GHC import qualified HscTypes import qualified NameSet import qualified Outputable import qualified PprTyThing import qualified Pretty import qualified TcHsSyn import qualified TcRnTypes getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String) getIdentifierInfo file identifier = withModSummary file $ \m -> do #if __GLASGOW_HASKELL__ >= 706 GHC.setContext [GHC.IIModule (GHC.moduleName (GHC.ms_mod m))] #elif __GLASGOW_HASKELL__ >= 704 GHC.setContext [GHC.IIModule (GHC.ms_mod m)] #else GHC.setContext [GHC.ms_mod m] [] #endif GHC.handleSourceError (return . Left . show) $ liftM Right (infoThing identifier) getType :: FilePath -> (Int, Int) -> GHC.Ghc (Either String [((Int, Int, Int, Int), String)]) getType file (line, col) = withModSummary file $ \m -> do p <- GHC.parseModule m typechecked <- GHC.typecheckModule p types <- processTypeCheckedModule typechecked (line, col) return (Right types) withModSummary :: String -> (HscTypes.ModSummary -> GHC.Ghc (Either String a)) -> GHC.Ghc (Either String a) withModSummary file action = do let noPhase = Nothing target <- GHC.guessTarget file noPhase GHC.setTargets [target] let handler err = GHC.printException err >> return GHC.Failed flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) case flag of GHC.Failed -> return (Left "Error loading targets") GHC.Succeeded -> do modSummary <- getModuleSummary file case modSummary of Nothing -> return (Left "Module not found in module graph") Just m -> action m getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary) getModuleSummary file = do moduleGraph <- GHC.getModuleGraph case find (moduleSummaryMatchesFilePath file) moduleGraph of Nothing -> return Nothing Just moduleSummary -> return (Just moduleSummary) moduleSummaryMatchesFilePath :: FilePath -> GHC.ModSummary -> Bool moduleSummaryMatchesFilePath file moduleSummary = let location = GHC.ms_location moduleSummary location_file = GHC.ml_hs_file location in case location_file of Just f -> f == file Nothing -> False ------------------------------------------------------------------------------ -- Most of the following code was taken from the source code of 'ghc-mod' (with -- some stylistic changes) -- -- ghc-mod: -- http://www.mew.org/~kazu/proj/ghc-mod/ -- https://github.com/kazu-yamamoto/ghc-mod/ processTypeCheckedModule :: GHC.TypecheckedModule -> (Int, Int) -> GHC.Ghc [((Int, Int, Int, Int), String)] processTypeCheckedModule tcm (line, col) = do let tcs = GHC.tm_typechecked_source tcm bs = listifySpans tcs (line, col) :: [GHC.LHsBind GHC.Id] es = listifySpans tcs (line, col) :: [GHC.LHsExpr GHC.Id] ps = listifySpans tcs (line, col) :: [GHC.LPat GHC.Id] bts <- mapM (getTypeLHsBind tcm) bs ets <- mapM (getTypeLHsExpr tcm) es pts <- mapM (getTypeLPat tcm) ps #if __GLASGOW_HASKELL__ >= 706 dflags <- DynFlags.getDynFlags return $ map (toTup dflags) $ #else return $ map toTup $ #endif sortBy cmp $ catMaybes $ concat [ets, bts, pts] where cmp (a, _) (b, _) | a `GHC.isSubspanOf` b = LT | b `GHC.isSubspanOf` a = GT | otherwise = EQ #if __GLASGOW_HASKELL__ >= 706 toTup :: GHC.DynFlags -> (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) toTup dflags (spn, typ) = (fourInts spn, pretty dflags typ) #else toTup :: (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) toTup (spn, typ) = (fourInts spn, pretty typ) #endif fourInts :: GHC.SrcSpan -> (Int, Int, Int, Int) fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan getSrcSpan :: GHC.SrcSpan -> Maybe (Int, Int, Int, Int) getSrcSpan (GHC.RealSrcSpan spn) = Just (GHC.srcSpanStartLine spn , GHC.srcSpanStartCol spn , GHC.srcSpanEndLine spn , GHC.srcSpanEndCol spn) getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLHsExpr tcm e = do hs_env <- GHC.getSession (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e return () case mbe of Nothing -> return Nothing Just expr -> return $ Just (GHC.getLoc e, CoreUtils.exprType expr) where modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm getTypeLPat :: GHC.TypecheckedModule -> GHC.LPat GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLPat _ (GHC.L spn pat) = return $ Just (spn, TcHsSyn.hsPatType pat) listifySpans :: Typeable a => GHC.TypecheckedSource -> (Int, Int) -> [GHC.Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs where p (GHC.L spn _) = GHC.isGoodSrcSpan spn && spn `GHC.spans` lc listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) #if __GLASGOW_HASKELL__ >= 706 pretty :: GHC.DynFlags -> GHC.Type -> String pretty dflags = #else pretty :: GHC.Type -> String pretty = #endif Pretty.showDocWith Pretty.OneLineMode #if __GLASGOW_HASKELL__ >= 706 . Outputable.withPprStyleDoc dflags #else . Outputable.withPprStyleDoc #endif (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) . PprTyThing.pprTypeForUser False ------------------------------------------------------------------------------ -- The following was taken from 'ghc-syb-utils' -- -- ghc-syb-utils: -- https://github.com/nominolo/ghc-syb -- | Ghc Ast types tend to have undefined holes, to be filled -- by later compiler phases. We tag Asts with their source, -- so that we can avoid such holes based on who generated the Asts. data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show) -- | Like 'everything', but avoid known potholes, based on the 'Stage' that -- generated the Ast. everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r everythingStaged stage k z f x | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool postTcType = const (stage Bool fixity = const (stage Bool ------------------------------------------------------------------------------ -- The following code was taken from GHC's ghc/InteractiveUI.hs (with some -- stylistic changes) infoThing :: String -> GHC.Ghc String infoThing str = do names <- GHC.parseName str mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual #if __GLASGOW_HASKELL__ >= 706 dflags <- DynFlags.getDynFlags return $ Outputable.showSDocForUser dflags unqual $ #else return $ Outputable.showSDocForUser unqual $ #endif Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data -- constructor in the same type filterOutChildren :: (a -> HscTypes.TyThing) -> [a] -> [a] filterOutChildren get_thing xs = filter (not . has_parent) xs where all_names = NameSet.mkNameSet (map (GHC.getName . get_thing) xs) #if __GLASGOW_HASKELL__ >= 704 has_parent x = case HscTypes.tyThingParent_maybe (get_thing x) of #else has_parent x = case PprTyThing.pprTyThingParent_maybe (get_thing x) of #endif Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False #if __GLASGOW_HASKELL__ >= 706 pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc #else pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc #endif pprInfo pefas (thing, fixity, insts) = PprTyThing.pprTyThingInContextLoc pefas thing Outputable.$$ show_fixity fixity Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) where show_fixity fix | fix == GHC.defaultFixity = Outputable.empty | otherwise = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing) hdevtools-0.1.0.5/src/Main.hs000066400000000000000000000042251206743641600157050ustar00rootroot00000000000000module Main where import System.Environment (getProgName) import System.IO (hPutStrLn, stderr) import Client (getServerStatus, serverCommand, stopServer) import CommandArgs import Daemonize (daemonize) import Server (startServer, createListenSocket) import Types (Command(..)) defaultSocketFilename :: FilePath defaultSocketFilename = ".hdevtools.sock" getSocketFilename :: Maybe FilePath -> FilePath getSocketFilename Nothing = defaultSocketFilename getSocketFilename (Just f) = f main :: IO () main = do args <- loadHDevTools let sock = getSocketFilename (socket args) case args of Admin {} -> doAdmin sock args Check {} -> doCheck sock args ModuleFile {} -> doModuleFile sock args Info {} -> doInfo sock args Type {} -> doType sock args doAdmin :: FilePath -> HDevTools -> IO () doAdmin sock args | start_server args = if noDaemon args then startServer sock Nothing else do s <- createListenSocket sock daemonize True $ startServer sock (Just s) | status args = getServerStatus sock | stop_server args = stopServer sock | otherwise = do progName <- getProgName hPutStrLn stderr "You must provide a command. See:" hPutStrLn stderr $ progName ++ " --help" doModuleFile :: FilePath -> HDevTools -> IO () doModuleFile sock args = serverCommand sock (CmdModuleFile (module_ args)) (ghcOpts args) doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> IO () doFileCommand cmdName cmd sock args | null (file args) = do progName <- getProgName hPutStrLn stderr "You must provide a haskell source file. See:" hPutStrLn stderr $ progName ++ " " ++ cmdName ++ " --help" | otherwise = serverCommand sock (cmd args) (ghcOpts args) doCheck :: FilePath -> HDevTools -> IO () doCheck = doFileCommand "check" $ \args -> CmdCheck (file args) doInfo :: FilePath -> HDevTools -> IO () doInfo = doFileCommand "info" $ \args -> CmdInfo (file args) (identifier args) doType :: FilePath -> HDevTools -> IO () doType = doFileCommand "type" $ \args -> CmdType (file args) (line args, col args) hdevtools-0.1.0.5/src/Server.hs000066400000000000000000000060561206743641600162730ustar00rootroot00000000000000module Server where import Control.Exception (bracket, finally, tryJust) import Control.Monad (guard) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose) import System.Directory (removeFile) import System.Exit (ExitCode(ExitSuccess)) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn) import System.IO.Error (isDoesNotExistError) import CommandLoop (newCommandLoopState, startCommandLoop) import Types (ClientDirective(..), Command, ServerDirective(..)) import Util (readMaybe) createListenSocket :: FilePath -> IO Socket createListenSocket socketPath = listenOn (UnixSocket socketPath) startServer :: FilePath -> Maybe Socket -> IO () startServer socketPath mbSock = do case mbSock of Nothing -> bracket (createListenSocket socketPath) cleanup go Just sock -> (go sock) `finally` (cleanup sock) where cleanup :: Socket -> IO () cleanup sock = do sClose sock removeSocketFile go :: Socket -> IO () go sock = do state <- newCommandLoopState currentClient <- newIORef Nothing startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing removeSocketFile :: IO () removeSocketFile = do -- Ignore possible error if socket file does not exist _ <- tryJust (guard . isDoesNotExistError) $ removeFile socketPath return () clientSend :: IORef (Maybe Handle) -> ClientDirective -> IO () clientSend currentClient clientDirective = do mbH <- readIORef currentClient case mbH of Just h -> do -- TODO catch exception hPutStrLn h (show clientDirective) hFlush h Nothing -> error "This is impossible" getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, [String])) getNextCommand currentClient sock = do checkCurrent <- readIORef currentClient case checkCurrent of Just h -> hClose h Nothing -> return () (h, _, _) <- accept sock writeIORef currentClient (Just h) msg <- hGetLine h -- TODO catch exception let serverDirective = readMaybe msg case serverDirective of Nothing -> do clientSend currentClient $ ClientUnexpectedError $ "The client sent an invalid message to the server: " ++ show msg getNextCommand currentClient sock Just (SrvCommand cmd ghcOpts) -> do return $ Just (cmd, ghcOpts) Just SrvStatus -> do mapM_ (clientSend currentClient) $ [ ClientStdout "Server is running." , ClientExit ExitSuccess ] getNextCommand currentClient sock Just SrvExit -> do mapM_ (clientSend currentClient) $ [ ClientStdout "Shutting down server." , ClientExit ExitSuccess ] -- Must close the handle here because we are exiting the loop so it -- won't be closed in the code above hClose h return Nothing hdevtools-0.1.0.5/src/Types.hs000066400000000000000000000011341206743641600161210ustar00rootroot00000000000000module Types ( ServerDirective(..) , ClientDirective(..) , Command(..) ) where import System.Exit (ExitCode) data ServerDirective = SrvCommand Command [String] | SrvStatus | SrvExit deriving (Read, Show) data ClientDirective = ClientStdout String | ClientStderr String | ClientExit ExitCode | ClientUnexpectedError String -- ^ For unexpected errors that should not happen deriving (Read, Show) data Command = CmdCheck FilePath | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) deriving (Read, Show) hdevtools-0.1.0.5/src/Util.hs000066400000000000000000000005541206743641600157370ustar00rootroot00000000000000module Util ( readMaybe ) where -- Taken from: -- http://stackoverflow.com/questions/8066850/why-doesnt-haskells-prelude-read-return-a-maybe/8080084#8080084 readMaybe :: (Read a) => String -> Maybe a readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of [x] -> Just x _ -> Nothing hdevtools-0.1.0.5/test_all_hsenv.sh000077500000000000000000000001021206743641600172350ustar00rootroot00000000000000#!/bin/sh ./test_hsenv.sh `echo .hsenv_* | sed -e 's/.hsenv_//g'` hdevtools-0.1.0.5/test_hsenv.sh000077500000000000000000000004661206743641600164220ustar00rootroot00000000000000#!/bin/bash set -e if [ $# -lt 1 ] then echo "Usage:" echo "$0 [ ...]" exit 2 fi for i in $* do source .hsenv_$i/bin/activate cabal build export HDEVTOOLS=./dist_$i/build/hdevtools/hdevtools ./tests/test_runner.sh deactivate_hsenv done echo echo 'All Tests Passed in:' $* hdevtools-0.1.0.5/tests/000077500000000000000000000000001206743641600150355ustar00rootroot00000000000000hdevtools-0.1.0.5/tests/Child.hs000066400000000000000000000001211206743641600164060ustar00rootroot00000000000000module Child where import Parent child :: String child = "child of " ++ parent hdevtools-0.1.0.5/tests/Parent.hs000066400000000000000000000000701206743641600166170ustar00rootroot00000000000000module Parent where parent :: String parent = "parent" hdevtools-0.1.0.5/tests/SampleError.hs000066400000000000000000000002721206743641600176250ustar00rootroot00000000000000-- Sample Module used for testing -- This module should cause a compilation error: -- -- Sample2.hs:9:1: parse error (possibly incorrect indentation) module SampleError where a = foo hdevtools-0.1.0.5/tests/Simple.hs000066400000000000000000000002231206743641600166170ustar00rootroot00000000000000-- Sample Module used for testing -- This module contains no errors or warnings module Sample1 where increment :: Int -> Int increment x = x + 1 hdevtools-0.1.0.5/tests/test_module_file.sh000066400000000000000000000003141206743641600207120ustar00rootroot00000000000000#!/bin/sh set -e SOCK=`mktemp -u` $HDEVTOOLS check --socket=$SOCK Child.hs PARENT=`$HDEVTOOLS modulefile --socket=$SOCK Parent` [ "$PARENT" = "./Parent.hs" ] $HDEVTOOLS --socket=$SOCK --stop-server hdevtools-0.1.0.5/tests/test_runner.sh000077500000000000000000000015621206743641600177500ustar00rootroot00000000000000#!/bin/sh set -e ALL_TESTS="\ test_start_stop.sh \ test_simple_check.sh \ test_sample_error.sh \ test_module_file.sh \ " if [ ! $HDEVTOOLS ] then echo 'You must set the HDEVTOOLS environment variable to the path of the hdevtools binary' exit 1 fi case "$HDEVTOOLS" in */*) # Convert relative path to absolute: export HDEVTOOLS=`pwd`/$HDEVTOOLS esac echo $HDEVTOOLS if [ $# -ne 0 ] then TESTS=$* else TESTS=$ALL_TESTS echo 'Running All Tests' fi echo '------------------------------------------------------------------------' cd `dirname $0` ERRORS=0 for i in $TESTS do echo $i echo if sh $i then echo 'Test OK' else echo 'Test FAILED' ERRORS=`expr $ERRORS + 1` fi echo '------------------------------------------------------------------------' done if [ $ERRORS = 0 ] then echo 'All Tests OK' else echo $ERRORS 'FAILED Tests' fi exit $ERRORS hdevtools-0.1.0.5/tests/test_sample_error.sh000066400000000000000000000003771206743641600211310ustar00rootroot00000000000000#!/bin/sh set -e SOCK=`mktemp -u` EXPECTED_ERRORS='SampleError.hs:9:5: Not in scope: `foo'\''' if ERRORS=`$HDEVTOOLS check --socket=$SOCK SampleError.hs` then false elsh [ "$ERRORS" = "$EXPECTED_ERRORS" ] fi $HDEVTOOLS --socket=$SOCK --stop-server hdevtools-0.1.0.5/tests/test_simple_check.sh000066400000000000000000000002231206743641600210530ustar00rootroot00000000000000#!/bin/sh set -e SOCK=`mktemp -u` ERRORS=`$HDEVTOOLS check --socket=$SOCK Simple.hs` [ -z "$ERRORS" ] $HDEVTOOLS --socket=$SOCK --stop-server hdevtools-0.1.0.5/tests/test_start_stop.sh000066400000000000000000000006301206743641600206310ustar00rootroot00000000000000#!/bin/sh set -e SOCK=`mktemp -u` echo '> Starting the server' $HDEVTOOLS --socket=$SOCK --start-server echo '> Checking status' $HDEVTOOLS --socket=$SOCK --status echo '> Checking that the socket file exists' if [ ! -S $SOCK ]; then false; fi echo '> Stopping the server' $HDEVTOOLS --socket=$SOCK --stop-server echo '> Checking that the socket file no longer exists' if [ -e $SOCK ]; then false; fi