diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/hdevtools.cabal b/hdevtools.cabal --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -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 diff --git a/src/Cabal.hs b/src/Cabal.hs --- a/src/Cabal.hs +++ b/src/Cabal.hs @@ -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 diff --git a/src/Client.hs b/src/Client.hs --- a/src/Client.hs +++ b/src/Client.hs @@ -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 diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -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 diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -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 diff --git a/src/Info.hs b/src/Info.hs --- a/src/Info.hs +++ b/src/Info.hs @@ -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 Bool #else postTcType = const (stage Bool @@ -287,3 +300,4 @@ show_fixity fix | fix == GHC.defaultFixity = Outputable.empty | otherwise = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing) + diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -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 ] diff --git a/src/Stack.hs b/src/Stack.hs --- a/src/Stack.hs +++ b/src/Stack.hs @@ -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