hdevtools 0.1.5.0 → 0.1.6.0
raw patch · 7 files changed
+133/−47 lines, 7 files
Files
- CHANGELOG.md +10/−1
- README.md +22/−2
- hdevtools.cabal +1/−1
- src/Cabal.hs +9/−7
- src/CommandArgs.hs +55/−4
- src/CommandLoop.hs +35/−10
- src/Main.hs +1/−22
CHANGELOG.md view
@@ -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
README.md view
@@ -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 -------
hdevtools.cabal view
@@ -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
src/Cabal.hs view
@@ -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"
src/CommandArgs.hs view
@@ -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)
src/CommandLoop.hs view
@@ -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 ()
src/Main.hs view
@@ -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