diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,17 @@ # Changelog +## 0.1.6.0 - 2017-08-21 + + * Added handling of source errors: GHC `SourceError` and other exceptions are + now correctly sent to the frontend process. This enables `hdevtools` to + correctly report haskell syntax errors and improves visibility of exceptions + leading the backend process to die. + * `.hdevtoolsrc` file for project-specific configuration. + * Use of `stack` can be turned off with `--nostack`. + ## 0.1.5.0 - 2016-12-23 - * (Re-)added template haskell support when required. Can be turned off using `--noTH`. + * (Re-)added template haskell support when required. Can be turned off using `--noth`. * Fixed system installed GHC libdir paths using stack. ## 0.1.4.1 - 2016-09-04 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -194,14 +194,34 @@ $ hdevtools check -g '-hide-package transformers' Foo.hs +In general, you will need to pass to `hdevtools` the same GHC options that you +would pass to GHCi. + +For projects with custom build systems, you can prevent `hdevtools` from +detecting a global `stack.yaml` configuration with the argument `--nostack`. + +#### Specifying GHC Options in Vim #### + 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. +#### Specifying GHC Options with `.hdevtoolsrc` #### + +If an `.hdevtoolsrc` file is present, then `hdevtools` will +parse arguments from the `.hdevtoolsrc` file after arguments from the command +line. + +For example, for the above project, the `.hdevtoolsrc` file would contain: + + -g -isrc -g -Wall -g -hide-package -g transformers + +The `.hdevtoolsrc` file will be searched for in the target path and all parents +of the target path, or, if the `hdevtools` command has no target, in `$PWD` and +all parents of `$PWD`. + Credits ------- diff --git a/hdevtools.cabal b/hdevtools.cabal --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -1,5 +1,5 @@ name: hdevtools -version: 0.1.5.0 +version: 0.1.6.0 synopsis: Persistent GHC powered background server for FAST haskell development tools license: MIT license-file: LICENSE diff --git a/src/Cabal.hs b/src/Cabal.hs --- a/src/Cabal.hs +++ b/src/Cabal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Cabal ( getPackageGhcOpts - , findCabalFile + , findCabalFile, findFile ) where import Stack @@ -256,20 +256,22 @@ extractValue = fst . break (`elem` "\n\r") . dropWhile isSpace . drop (length pkgDbKey) -findCabalFile :: FilePath -> IO (Maybe FilePath) -findCabalFile dir = do +-- | looks for file matching a predicate starting from dir and going up until root +findFile :: (FilePath -> Bool) -> FilePath -> IO (Maybe FilePath) +findFile p dir = do allFiles <- getDirectoryContents dir - let mbCabalFile = find (isCabalFile) allFiles - case mbCabalFile of + case find p allFiles of Just cabalFile -> return $ Just $ dir cabalFile Nothing -> let parentDir = takeDirectory dir in if parentDir == dir then return Nothing - else findCabalFile parentDir + else findFile p parentDir - where +findCabalFile :: FilePath -> IO (Maybe FilePath) +findCabalFile = findFile isCabalFile + where isCabalFile :: FilePath -> Bool isCabalFile path = ".cabal" `isSuffixOf` path && length path > length ".cabal" diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -3,15 +3,20 @@ module CommandArgs ( HDevTools(..) , loadHDevTools + , pathArg ) where +import Cabal (findFile) import Data.Version (showVersion) import Paths_hdevtools (version) +import qualified Config import System.Console.CmdArgs.Implicit -import System.Environment (getProgName) +import System.Console.CmdArgs.Explicit (splitArgs) +import System.Directory (getCurrentDirectory) +import System.Environment (getProgName, withArgs, getArgs) +import System.FilePath (takeDirectory) import System.Info (arch, os) -import qualified Config programVersion :: String programVersion = @@ -41,6 +46,7 @@ , status :: Bool , stop_server :: Bool , debug :: Bool + , noStack :: Bool } | Check { socket :: Maybe FilePath @@ -50,6 +56,7 @@ , file :: String , json :: Bool , debug :: Bool + , noStack :: Bool , noTH :: Bool } | ModuleFile @@ -58,6 +65,7 @@ , cabalOpts :: [String] , module_ :: String , debug :: Bool + , noStack :: Bool } | Info { socket :: Maybe FilePath @@ -67,6 +75,7 @@ , file :: String , identifier :: String , debug :: Bool + , noStack :: Bool , noTH :: Bool } | Type @@ -78,6 +87,7 @@ , line :: Int , col :: Int , debug :: Bool + , noStack :: Bool , noTH :: Bool } | FindSymbol @@ -87,6 +97,7 @@ , symbol :: String , files :: [String] , debug :: Bool + , noStack :: Bool , noTH :: Bool } deriving (Show, Data, Typeable) @@ -101,6 +112,7 @@ , status = False , stop_server = False , debug = False + , noStack = False } dummyCheck :: HDevTools @@ -113,6 +125,7 @@ , json = False , debug = False , noTH = False + , noStack = False } dummyModuleFile :: HDevTools @@ -122,6 +135,7 @@ , cabalOpts = [] , module_ = "" , debug = False + , noStack = False } dummyInfo :: HDevTools @@ -133,6 +147,7 @@ , file = "" , identifier = "" , debug = False + , noStack = False , noTH = False } @@ -146,6 +161,7 @@ , line = 0 , col = 0 , debug = False + , noStack = False , noTH = False } @@ -157,6 +173,7 @@ , symbol = "" , files = [] , debug = False + , noStack = False , noTH = False } @@ -169,7 +186,8 @@ , noDaemon := def += help "do not daemonize (only if --start-server)" , status := def += help "show status of server" , stop_server := def += help "shutdown the server" - , debug := def += help "enable debug output" + , debug := def += help "enable debug output" + , noStack := def += name "S" += help "disable stack integration" ] += help "Interactions with the server" check :: Annotate Ann @@ -181,6 +199,7 @@ , file := def += typFile += argPos 0 += opt "" , json := def += help "render output as JSON" , debug := def += help "enable debug output" + , noStack := def += name "S" += help "disable stack integration" , noTH := def += help "disable template haskell" ] += help "Check a haskell source file for errors and warnings" @@ -191,6 +210,7 @@ , cabalOpts := def += typ "OPTION" += help "cabal options" , module_ := def += typ "MODULE" += argPos 0 , debug := def += help "enable debug output" + , noStack := def += name "S" += help "disable stack integration" ] += help "Get the haskell source file corresponding to a module name" info :: Annotate Ann @@ -202,6 +222,7 @@ , file := def += typFile += argPos 0 += opt "" , identifier := def += typ "IDENTIFIER" += argPos 1 , debug := def += help "enable debug output" + , noStack := def += name "S" += help "disable stack integration" , noTH := def += help "disable template haskell" ] += help "Get info from GHC about the specified identifier" @@ -211,6 +232,7 @@ , ghcOpts := def += typ "OPTION" += help "ghc options" , cabalOpts := def += typ "OPTION" += help "cabal options" , debug := def += help "enable debug output" + , noStack := def += name "S" += help "disable stack integration" , path := def += typFile += help "path to target file" , file := def += typFile += argPos 0 += opt "" , line := def += typ "LINE" += argPos 1 @@ -226,6 +248,7 @@ , symbol := def += typ "SYMBOL" += argPos 0 , files := def += typFile += args , debug := def += help "enable debug output" + , noStack := def += name "S" += help "disable stack integration" , noTH := def += help "disable template haskell" ] += help "List the modules where the given symbol could be found" @@ -236,7 +259,35 @@ += program progName += summary (progName ++ ": " ++ fullVersion) + +fileArg :: HDevTools -> Maybe String +fileArg (Admin {}) = Nothing +fileArg (ModuleFile {}) = Nothing +fileArg a@(Check {}) = Just $ file a +fileArg a@(Info {}) = Just $ file a +fileArg a@(Type {}) = Just $ file a +fileArg (FindSymbol {}) = Nothing + +pathArg' :: HDevTools -> Maybe String +pathArg' (Admin {}) = Nothing +pathArg' (ModuleFile {}) = Nothing +pathArg' a@(Check {}) = path a +pathArg' a@(Info {}) = path a +pathArg' a@(Type {}) = path a +pathArg' (FindSymbol {}) = Nothing + +pathArg :: HDevTools -> Maybe String +pathArg a = case pathArg' a of + Just x -> Just x + Nothing -> fileArg a + + loadHDevTools :: IO HDevTools loadHDevTools = do progName <- getProgName - (cmdArgs_ (full progName) :: IO HDevTools) + cfg0 <- cmdArgs_ (full progName) + dir <- maybe getCurrentDirectory (return . takeDirectory) $ pathArg cfg0 + mConfig <- findFile (== ".hdevtoolsrc") dir + perProject <- maybe (return []) (\f -> splitArgs `fmap` readFile f) mConfig + args0 <- getArgs + withArgs (args0 ++ perProject) $ cmdArgs_ (full progName) diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ViewPatterns #-} + module CommandLoop ( newCommandLoopState , Config(..) @@ -7,6 +8,7 @@ , startCommandLoop ) where +import Control.Exception import Control.Applicative ((<|>)) import Control.Monad (when, void) import Data.IORef @@ -25,6 +27,8 @@ import qualified DynFlags #endif import qualified GHC +import qualified GhcPlugins as GHC +import qualified ErrUtils as GHC import qualified GHC.Paths import qualified Outputable import System.Posix.Types (EpochTime) @@ -136,16 +140,38 @@ Just (cmd, config) -> if forceReconfig || (config /= initialConfig) then return (Just (cmd, config)) - else sendErrors (runCommand state clientSend initialConfig cmd) >> processNextCommand False + else do + sendErrors (runCommand state clientSend initialConfig cmd) + processNextCommand False sendErrors :: GHC.Ghc () -> GHC.Ghc () - sendErrors action = GHC.gcatch action $ \e -> do - liftIO $ mapM_ clientSend - [ ClientStderr $ GHC.showGhcException e "" - , ClientExit (ExitFailure 1) - ] - return () + sendErrors action = do + action `GHC.gcatch` ghcError + `GHC.gcatch` sourceError + `GHC.gcatch` unknownError + where + ghcError :: GHC.GhcException -> GHC.Ghc () + ghcError = die . flip GHC.showGhcException "" + unknownError :: SomeException -> GHC.Ghc () + unknownError = die . show + + sourceError :: GHC.SourceError -> GHC.Ghc () + sourceError = report + + die msg = liftIO $ mapM_ clientSend + [ ClientStderr msg + , ClientExit (ExitFailure 1) + ] + + report (GHC.srcErrorMessages -> bag) = do + flags <- GHC.getSessionDynFlags + let msgs = map (Outputable.showSDoc flags) $ GHC.pprErrMsgBagWithLoc bag + liftIO $ do + mapM_ (logActionSend state clientSend GHC.SevError) msgs + clientSend $ ClientExit ExitSuccess + + doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () doMaybe Nothing _ = return () doMaybe (Just x) f = f x @@ -191,8 +217,7 @@ when (GHC.needsTemplateHaskell graph) $ do flags <- GHC.getSessionDynFlags void . GHC.setSessionDynFlags $ flags { GHC.hscTarget = GHC.HscInterpreted, GHC.ghcLink = GHC.LinkInMemory } - let handler err = GHC.printException err >> return GHC.Failed - fmap Just $ GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) + Just <$> GHC.load GHC.LoadAllTargets else return Nothing withTargets :: ClientSend -> [FilePath] -> Config -> GHC.Ghc () -> GHC.Ghc () diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -32,27 +32,6 @@ defaultSocketFile = ".hdevtools.sock" -fileArg :: HDevTools -> Maybe String -fileArg (Admin {}) = Nothing -fileArg (ModuleFile {}) = Nothing -fileArg args@(Check {}) = Just $ file args -fileArg args@(Info {}) = Just $ file args -fileArg args@(Type {}) = Just $ file args -fileArg (FindSymbol {}) = Nothing - -pathArg' :: HDevTools -> Maybe String -pathArg' (Admin {}) = Nothing -pathArg' (ModuleFile {}) = Nothing -pathArg' args@(Check {}) = path args -pathArg' args@(Info {}) = path args -pathArg' args@(Type {}) = path args -pathArg' (FindSymbol {}) = Nothing - -pathArg :: HDevTools -> Maybe String -pathArg args = case pathArg' args of - Just x -> Just x - Nothing -> fileArg args - main :: IO () main = do args <- loadHDevTools @@ -61,7 +40,7 @@ mCabalFile <- findCabalFile dir >>= traverse absoluteFilePath when (debug args) . putStrLn $ "Cabal file: " <> show mCabalFile - mStackYaml <- findStackYaml dir + mStackYaml <- if noStack args then return Nothing else findStackYaml dir when (debug args) . putStrLn $ "Stack file: " <> show mStackYaml let extra = emptyCommandExtra