hdevtools 0.1.7.0 → 0.1.8.0
raw patch · 10 files changed
+145/−91 lines, 10 files
Files
- CHANGELOG.md +4/−0
- README.md +15/−1
- hdevtools.cabal +1/−1
- src/Cabal.hs +16/−10
- src/Client.hs +30/−25
- src/CommandArgs.hs +12/−12
- src/CommandLoop.hs +8/−9
- src/Info.hs +18/−4
- src/Server.hs +40/−28
- src/Stack.hs +1/−1
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Changelog +## 0.1.8.0 - 2019-03-10++ * Add support for ghc-8.6 and Cabal-2.4.+ ## 0.1.7.0 - 2018-08-08 * Add support for ghc-8.4 and Cabal-2.2.
README.md view
@@ -67,9 +67,22 @@ used by [vim-hdevtools][3], see below). See the section "Specifying GHC Options" below for details how to use it. +### Vim - [ALE][16] ###++[ALE][16] is an asynchronous linting and fixing suite for Vim and NeoVim.+Support for `hdevtools` is built-in since v1.2.0 (Feb. 2017).++Install `hdevtools` (see above) and [ALE][16], and it will automatically and+asynchronously (as you type) check your Haskell files.++[ALE][16] can pass `g:ale_haskell_hdevtools_options` variable to CLI `hdevtools`,+it's the same as configuring `g:hdevtools_options` (see "Specifying GHC Options"+below). `g:ale_haskell_hdevtools_executable` can be used to set an alternate+path to `hdevtools`.+ ### Vim - [vim-hdevtools][3] ### -In addition to Syntastic, it is recommended that you also use+In addition to Syntastic or ALE, 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,@@ -244,3 +257,4 @@ [13]: https://github.com/schell/hdevtools [14]: https://www.stackage.org/package/hdevtools [15]: haskellstack.org+[16]: https://github.com/w0rp/ale
hdevtools.cabal view
@@ -1,5 +1,5 @@ name: hdevtools-version: 0.1.7.0+version: 0.1.8.0 synopsis: Persistent GHC powered background server for FAST haskell development tools license: MIT license-file: LICENSE
src/Cabal.hs view
@@ -11,6 +11,7 @@ import Control.Monad.Trans.State (execStateT, modify) import Data.Char (isSpace) import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf)+import Data.Maybe (isJust) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) import Data.Monoid (Monoid(..))@@ -91,9 +92,9 @@ -- cabal configure --package-db=clear --package-db=global --package-db=$(stack path --snapshot-pkg-db) --package-db=$(stack path --local-pkg-db) getPackageGhcOpts :: FilePath -> Maybe StackConfig -> [String] -> IO (Either String [String])-getPackageGhcOpts path mbStack opts = do- getPackageGhcOpts' `catch` (\e -> do- return $ Left $ "Cabal error: " ++ (ioeGetErrorString (e :: IOException)))+getPackageGhcOpts path mbStack opts =+ getPackageGhcOpts' `catch` (\e ->+ return $ Left $ "Cabal error: " ++ ioeGetErrorString (e :: IOException)) where getPackageGhcOpts' :: IO (Either String [String]) getPackageGhcOpts' = do@@ -118,7 +119,7 @@ let sandboxConfig = takeDirectory path </> "cabal.sandbox.config" exists <- lift $ doesFileExist sandboxConfig- when (exists) $ do+ when exists $ do sandboxPackageDb <- lift $ getSandboxPackageDB sandboxConfig modify $ \x -> x { configPackageDBs = [Just sandboxPackageDb] } @@ -138,13 +139,19 @@ let mbLibName = pkgLibName pkgDescr #endif let ghcOpts' = foldl' mappend mempty . map (getComponentGhcOptions localBuildInfo) .- flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo+ flip allComponentsBy id . localPkgDescr $ localBuildInfo -- FIX bug in GhcOptions' `mappend`-#if MIN_VERSION_Cabal(1,21,1)+#if MIN_VERSION_Cabal(2,4,0)+-- API Change, just for the glory of Satan:+-- Distribution.Simple.Program.GHC.GhcOptions no longer uses NubListR's+ ghcOpts = ghcOpts' { ghcOptExtra = filter (/= "-Werror") $ ghcOptExtra ghcOpts'+#elif MIN_VERSION_Cabal(1,21,1) -- API Change: -- Distribution.Simple.Program.GHC.GhcOptions now uses NubListR's -- GhcOptions { .. ghcOptPackages :: NubListR (InstalledPackageId, PackageId, ModuleRemaining) .. } ghcOpts = ghcOpts' { ghcOptExtra = overNubListR (filter (/= "-Werror")) $ ghcOptExtra ghcOpts'+#endif+#if MIN_VERSION_Cabal(1,21,1) #if __GLASGOW_HASKELL__ >= 709 , ghcOptPackageDBs = sort $ nub (ghcOptPackageDBs ghcOpts') #endif@@ -199,7 +206,7 @@ #endif hasLibrary :: PackageDescription -> Bool-hasLibrary = maybe False (\_ -> True) . library+hasLibrary = isJust . library getComponentGhcOptions :: LocalBuildInfo -> Component -> GhcOptions getComponentGhcOptions lbi comp =@@ -221,9 +228,8 @@ where pkgDbKey = "package-db:" parse = head . filter (pkgDbKey `isPrefixOf`) . lines- extractValue = fst . break (`elem` "\n\r") . dropWhile isSpace . drop (length pkgDbKey)--+ extractValue = takeWhile (`notElem` "\n\r") . dropWhile isSpace . drop (length pkgDbKey)+ -- | 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
src/Client.hs view
@@ -4,42 +4,47 @@ , 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(..), CommandExtra(..), ServerDirective(..))-import Util (readMaybe)+import Control.Exception (bracket, tryJust)+import Control.Monad (guard)+import Daemonize (daemonize)+import Network.Socket (Family (AF_UNIX), SockAddr (SockAddrUnix),+ SocketType (Stream), connect,+ defaultProtocol, socket, socketToHandle)+import Server (createListenSocket, startServer)+import System.Exit (exitFailure, exitWith)+import System.IO (Handle, IOMode (ReadWriteMode), hClose,+ hFlush, hGetLine, hPrint, hPutStrLn, stderr)+import System.IO.Error (isDoesNotExistError)+import Types (ClientDirective (..), Command (..),+ CommandExtra (..), ServerDirective (..))+import Util (readMaybe) -connect :: FilePath -> IO Handle-connect sock = do- connectTo "" (UnixSocket sock)+connectSocket :: FilePath -> IO Handle+connectSocket sock = do+ s <- socket AF_UNIX Stream defaultProtocol+ connect s (SockAddrUnix sock)+ socketToHandle s ReadWriteMode getServerStatus :: FilePath -> IO ()-getServerStatus sock = do- h <- connect sock- hPutStrLn h $ show SrvStatus- hFlush h- startClientReadLoop h+getServerStatus sock =+ bracket (connectSocket sock) hClose $ \h -> do+ hPrint h SrvStatus+ hFlush h+ startClientReadLoop h stopServer :: FilePath -> IO () stopServer sock = do- h <- connect sock- hPutStrLn h $ show SrvExit- hFlush h- startClientReadLoop h+ bracket (connectSocket sock) hClose $ \h -> do+ hPrint h SrvExit+ hFlush h+ startClientReadLoop h serverCommand :: FilePath -> Command -> CommandExtra -> IO () serverCommand sock cmd cmdExtra = do- r <- tryJust (guard . isDoesNotExistError) (connect sock)+ r <- tryJust (guard . isDoesNotExistError) (connectSocket sock) case r of Right h -> do- hPutStrLn h $ show (SrvCommand cmd cmdExtra)+ hPrint h (SrvCommand cmd cmdExtra) hFlush h startClientReadLoop h Left _ -> do
src/CommandArgs.hs view
@@ -261,20 +261,20 @@ 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+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' 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
src/CommandLoop.hs view
@@ -48,7 +48,7 @@ } newCommandLoopState :: IO (IORef State)-newCommandLoopState = do+newCommandLoopState = newIORef $ State { stateWarningsEnabled = True }@@ -81,7 +81,7 @@ mbCabalConfig <- traverse (\path -> mkCabalConfig path (ceCabalOptions cmdExtra)) $ ceCabalFilePath cmdExtra - mbStackConfig <- if (stackYaml <$> msc) == (ceStackYamlPath cmdExtra)+ mbStackConfig <- if (stackYaml <$> msc) == ceStackYamlPath cmdExtra then return msc else getStackConfig cmdExtra @@ -97,13 +97,12 @@ withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a withWarnings state warningsValue action = do- beforeState <- liftIO $ getWarnings+ beforeState <- liftIO getWarnings liftIO $ setWarnings warningsValue- action `GHC.gfinally`- (liftIO $ setWarnings beforeState)+ action `GHC.gfinally` liftIO (setWarnings beforeState) where getWarnings :: IO Bool- getWarnings = readIORef state >>= return . stateWarningsEnabled+ getWarnings = stateWarningsEnabled <$> readIORef state setWarnings :: Bool -> IO () setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val } @@ -146,7 +145,7 @@ processNextCommand False sendErrors :: GHC.Ghc () -> GHC.Ghc ()- sendErrors action = do+ sendErrors action = action `GHC.gcatch` ghcError `GHC.gcatch` sourceError `GHC.gcatch` unknownError@@ -210,10 +209,10 @@ loadTarget :: [FilePath] -> Config -> GHC.Ghc (Maybe GHC.SuccessFlag) loadTarget files conf = do let noPhase = Nothing- targets <- mapM (flip GHC.guessTarget noPhase) files+ targets <- mapM (`GHC.guessTarget` noPhase) files GHC.setTargets targets graph <- GHC.depanal [] True- if configTH conf || (not $ needsTemplateHaskellOrQQ graph)+ if configTH conf || not (needsTemplateHaskellOrQQ graph) then do when (needsTemplateHaskellOrQQ graph) $ do flags <- GHC.getSessionDynFlags
src/Info.hs view
@@ -5,7 +5,6 @@ , getType ) where -import Control.Monad (liftM) import Data.Generics (GenericQ, mkQ, extQ, gmapQ) import Data.List (find, sortBy, intersperse) import Data.Maybe (catMaybes, fromMaybe)@@ -42,7 +41,7 @@ GHC.setContext [GHC.ms_mod m] [] #endif GHC.handleSourceError (return . Left . show) $- liftM Right (infoThing identifier)+ fmap Right (infoThing identifier) getType :: FilePath -> (Int, Int) -> GHC.Ghc (Either String [((Int, Int, Int, Int), String)]) getType file (line, col) =@@ -62,7 +61,7 @@ getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary) getModuleSummary file = do modSummaries <- getModSummaries- case find (moduleSummaryMatchesFilePath file) $ modSummaries of+ case find (moduleSummaryMatchesFilePath file) modSummaries of Nothing -> return Nothing Just moduleSummary -> return (Just moduleSummary) @@ -124,11 +123,15 @@ getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind TypecheckI -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))+#if __GLASGOW_HASKELL__ >= 806+getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty $ HsExpr.mg_ext grp)+#else #if __GLASGOW_HASKELL__ >= 708 getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty grp) #else getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) #endif+#endif getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr TypecheckI -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))@@ -208,10 +211,20 @@ -- generated the Ast. everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r everythingStaged stage k z f x+#if __GLASGOW_HASKELL__ >= 806+-- This is a hack, ghc 8.6 changed representation from PostTc+-- to a whole bunch of individial types and I don't really want+-- to handle all of them, at least for the moment since I'm not using+-- this functionality+ | (const False `extQ` fixity `extQ` nameSet) x = z+#else | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z+#endif | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 806+ -- there's no more "simple" PostTc type in ghc 8.6+#elif __GLASGOW_HASKELL__ >= 709 postTcType = const (stage<TypeChecker) :: GHC.PostTc TypecheckI GHC.Type -> Bool #else postTcType = const (stage<TypeChecker) :: GHC.PostTcType -> Bool@@ -287,3 +300,4 @@ show_fixity fix | fix == GHC.defaultFixity = Outputable.empty | otherwise = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing)+
src/Server.hs view
@@ -1,37 +1,50 @@ module Server where -import Control.Exception (bracket, finally, handleJust, tryJust)-import Control.Monad (guard)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import GHC.IO.Exception (IOErrorType(ResourceVanished))-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 (ioeGetErrorType, isAlreadyInUseError, isDoesNotExistError)+import Control.Exception (bracket, finally, handleJust, tryJust)+import Control.Monad (guard)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import GHC.IO.Exception (IOErrorType (ResourceVanished))+import Network.Socket (Family (AF_UNIX), SockAddr (SockAddrUnix),+ Socket, SocketType (Stream), accept, bind,+ close, defaultProtocol, listen, socket,+ socketToHandle)+import System.Directory (removeFile)+import System.Exit (ExitCode (ExitSuccess))+import System.IO (Handle, IOMode (ReadWriteMode), hClose,+ hFlush, hGetLine, hPrint)+import System.IO.Error (ioeGetErrorType, isAlreadyInUseError,+ isDoesNotExistError) -import CommandLoop (newCommandLoopState, Config, updateConfig, startCommandLoop)-import Types (ClientDirective(..), Command, CommandExtra(..), ServerDirective(..))-import Util (readMaybe)+import CommandLoop (Config, newCommandLoopState,+ startCommandLoop, updateConfig)+import Types (ClientDirective (..), Command,+ CommandExtra (..), ServerDirective (..))+import Util (readMaybe) createListenSocket :: FilePath -> IO Socket createListenSocket socketPath = do- r <- tryJust (guard . isAlreadyInUseError) $ listenOn (UnixSocket socketPath)+ r <- tryJust (guard . isAlreadyInUseError) listenOn case r of- Right socket -> return socket+ Right s -> return s Left _ -> do removeFile socketPath- listenOn (UnixSocket socketPath)+ listenOn+ where+ listenOn = do+ s <- socket AF_UNIX Stream defaultProtocol+ bind s $ SockAddrUnix socketPath+ listen s 1+ return s startServer :: FilePath -> Maybe Socket -> CommandExtra -> IO ()-startServer socketPath mbSock cmdExtra = do+startServer socketPath mbSock cmdExtra = case mbSock of- Nothing -> bracket (createListenSocket socketPath) cleanup go- Just sock -> (go sock) `finally` (cleanup sock)- where+ Nothing -> bracket (createListenSocket socketPath) cleanup go+ Just sock -> go sock `finally` cleanup sock+ where cleanup :: Socket -> IO () cleanup sock = do- sClose sock+ close sock removeSocketFile go :: Socket -> IO ()@@ -53,10 +66,10 @@ mbH <- readIORef currentClient case mbH of Just h -> ignoreEPipe $ do- hPutStrLn h (show clientDirective)+ hPrint h clientDirective hFlush h Nothing -> return ()- where+ where -- EPIPE means that the client is no longer there. ignoreEPipe = handleJust (guard . isEPipe) (const $ return ()) isEPipe = (==ResourceVanished) . ioeGetErrorType@@ -64,10 +77,9 @@ getNextCommand :: IORef (Maybe Handle) -> Socket -> IORef (Maybe Config) -> IO (Maybe (Command, Config)) getNextCommand currentClient sock config = do checkCurrent <- readIORef currentClient- case checkCurrent of- Just h -> hClose h- Nothing -> return ()- (h, _, _) <- accept sock+ maybe (return ()) hClose checkCurrent+ (s, _) <- accept sock+ h <- socketToHandle s ReadWriteMode writeIORef currentClient (Just h) msg <- hGetLine h -- TODO catch exception let serverDirective = readMaybe msg@@ -82,13 +94,13 @@ writeIORef config (Just config') return $ Just (cmd, config') Just SrvStatus -> do- mapM_ (clientSend currentClient) $+ mapM_ (clientSend currentClient) [ ClientStdout "Server is running." , ClientExit ExitSuccess ] getNextCommand currentClient sock config Just SrvExit -> do- mapM_ (clientSend currentClient) $+ mapM_ (clientSend currentClient) [ ClientStdout "Shutting down server." , ClientExit ExitSuccess ]
src/Stack.hs view
@@ -64,7 +64,7 @@ getStackDbs :: FilePath -> IO (Maybe [FilePath]) getStackDbs p = execStackInPath "path --ghc-package-path" p >>=- maybe (return Nothing) (\pp -> return <$> extractDbs pp)+ maybe (return Nothing) (fmap return . extractDbs) extractDbs :: String -> IO [FilePath] extractDbs = filterM doesDirectoryExist . stringPaths