diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,2 +1,8 @@ +# ghc-tags-1.1 (2021-05-18) +* Fix compatibility with GHC 8.10. +* Drop support for GHC 8.8. +* Make output flag `ctags` compatible. +* Increase allocation area to 4MB for better performance. + # ghc-tags-1.0 (2021-05-17) * Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,7 @@ # ghc-tags [![Build Status](https://github.com/arybczak/ghc-tags/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster) +[![Hackage](https://img.shields.io/hackage/v/ghc-tags.svg)](https://hackage.haskell.org/package/ghc-tags) A command line tool that generates etags (Emacs) and ctags (Vim and other editors) for efficient code navigation (jump to definition). diff --git a/ghc-tags.cabal b/ghc-tags.cabal --- a/ghc-tags.cabal +++ b/ghc-tags.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags -version: 1.0 +version: 1.1 synopsis: Utility for generating ctags and etags with GHC API. description: Utility for generating etags (Emacs) and ctags (Vim and other editors) with GHC API for efficient project navigation. @@ -14,7 +14,7 @@ README.md homepage: https://github.com/arybczak/ghc-tags bug-reports: https://github.com/arybczak/ghc-tags/issues -tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 +tested-with: GHC ==8.10.4 || ==9.0.1 source-repository head type: git @@ -26,14 +26,14 @@ description: Use ghc-lib even when compiling with compatible GHC version. executable ghc-tags - ghc-options: -Wall -threaded -rtsopts + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-A4m if !flag(ghc-lib) && impl(ghc == 9.0.*) build-depends: ghc, ghc-boot else build-depends: ghc-lib == 9.0.* - build-depends: base >=4.13 && <5 + build-depends: base >=4.14 && <5 , aeson , async , attoparsec @@ -61,6 +61,7 @@ GhcTags.Config.Args GhcTags.Config.Project GhcTags.Ghc + GhcTags.GhcCompat GhcTags.Tag GhcTags.CTag GhcTags.CTag.Header diff --git a/src/GhcTags/Config/Args.hs b/src/GhcTags/Config/Args.hs --- a/src/GhcTags/Config/Args.hs +++ b/src/GhcTags/Config/Args.hs @@ -51,7 +51,7 @@ <> help "Generate etags" tagFile :: Parser FilePath - tagFile = strOption $ long "output" + tagFile = strOption $ short 'f' <> short 'o' <> metavar "FILE" <> help "Output file" diff --git a/src/GhcTags/GhcCompat.hs b/src/GhcTags/GhcCompat.hs new file mode 100644 --- /dev/null +++ b/src/GhcTags/GhcCompat.hs @@ -0,0 +1,288 @@ +{-# OPTIONS_GHC -Wno-missing-fields #-} +module GhcTags.GhcCompat + ( runGhc + , parseModule + ) where + +import Data.IORef +import GHC.Data.FastString +import GHC.Data.StringBuffer +import GHC.Driver.Main +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Hs +import GHC.Parser.Lexer +import GHC.Paths +import GHC.Platform +import GHC.Settings +import GHC.Settings.Config +import GHC.Settings.Platform +import GHC.Settings.Utils +import GHC.SysTools +import GHC.SysTools.BaseDir +import GHC.Types.SrcLoc +import GHC.Unit.Module.Env +import GHC.Utils.Fingerprint +import System.Directory +import System.FilePath +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified GHC +import qualified GHC.Parser as Parser + +parseModule + :: FilePath + -> DynFlags + -> StringBuffer + -> ParseResult (Located HsModule) +parseModule filename flags buffer = unP Parser.parseModule parseState + where + location = mkRealSrcLoc (mkFastString filename) 1 1 + parseState = mkPState flags buffer location + +runGhc :: Ghc a -> IO a +runGhc m = do + env <- liftIO $ do + mySettings <- compatInitSettings libdir + myLlvmConfig <- lazyInitLlvmConfig libdir + dflags <- threadSafeInitDynFlags (defaultDynFlags mySettings myLlvmConfig) + newHscEnv dflags + ref <- newIORef env + unGhc (GHC.withCleanupSession m) (Session ref) + +---------------------------------------- +-- Internal + +-- | Adjusted version of 'GHC.Driver.Session.initDynFlags' that doesn't check +-- for colors as it's not thread safe. +threadSafeInitDynFlags :: DynFlags -> IO DynFlags +threadSafeInitDynFlags dflags = do + let -- We can't build with dynamic-too on Windows, as labels before the + -- fork point are different depending on whether we are building + -- dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo + refNextTempSuffix <- newIORef 0 + refFilesToClean <- newIORef emptyFilesToClean + refDirsToClean <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty + refRtldInfo <- newIORef Nothing + refRtccInfo <- newIORef Nothing + wrapperNum <- newIORef emptyModuleEnv + pure dflags + { canGenerateDynamicToo = refCanGenerateDynamicToo + , nextTempSuffix = refNextTempSuffix + , filesToClean = refFilesToClean + , dirsToClean = refDirsToClean + , generatedDumps = refGeneratedDumps + , nextWrapperNum = wrapperNum + , rtldInfo = refRtldInfo + , rtccInfo = refRtccInfo + } + +-- | Stripped version of 'GHC.Settings.IO.initSettings' that ignores the +-- @platformConstants@ file as it's irrelevant for parsing. +compatInitSettings :: FilePath -> IO Settings +compatInitSettings top_dir = do + -- see Note [topdir: How GHC finds its files] + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + mtool_dir <- findToolDir top_dir + -- see Note [tooldir: How GHC finds mingw on Windows] + + let installed :: FilePath -> FilePath + installed file = top_dir file + libexec :: FilePath -> FilePath + libexec file = top_dir "bin" file + settingsFile = installed "settings" + + readFileSafe :: FilePath -> IO String + readFileSafe path = doesFileExist path >>= \case + True -> readFile path + False -> error $ "Missing file: " ++ path + + settingsStr <- readFileSafe settingsFile + settingsList <- case maybeReadFuzzy settingsStr of + Just s -> pure s + Nothing -> error $ "Can't parse " ++ show settingsFile + let mySettings = Map.fromList settingsList + -- See Note [Settings file] for a little more about this file. We're + -- just partially applying those functions and throwing 'Left's; they're + -- written in a very portable style to keep ghc-boot light. + let getSetting key = either error pure $ + getFilePathSetting0 top_dir settingsFile mySettings key + getToolSetting :: String -> IO String + getToolSetting key = expandToolDir mtool_dir <$> getSetting key + getBooleanSetting :: String -> IO Bool + getBooleanSetting key = either error pure $ + getBooleanSetting0 settingsFile mySettings key + myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin, + -- as well as TopDir/../../mingw/bin for hadrian. + -- It would perhaps be nice to be able to override this + -- with the settings file, but it would be a little fiddly + -- to make that possible, so for now you can't. + cc_prog <- getToolSetting "C compiler command" + cc_args_str <- getSetting "C compiler flags" + cxx_args_str <- getSetting "C++ compiler flags" + gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" + cpp_prog <- getToolSetting "Haskell CPP command" + cpp_args_str <- getSetting "Haskell CPP flags" + + platform <- either error pure $ compatGetTargetPlatform settingsFile mySettings + + let unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cpp_args = map Option (words cpp_args_str) + cc_args = words cc_args_str ++ unreg_cc_args + cxx_args = words cxx_args_str + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" + ldSupportsBuildId <- getBooleanSetting "ld supports build-id" + ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldIsGnuLd <- getBooleanSetting "ld is GNU ld" + + let globalpkgdb_path = installed "package.conf.d" + ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path <- getToolSetting "unlit command" + + windres_path <- getToolSetting "windres command" + libtool_path <- getToolSetting "libtool command" + ar_path <- getToolSetting "ar command" + otool_path <- getToolSetting "otool command" + install_name_tool_path <- getToolSetting "install_name_tool command" + ranlib_path <- getToolSetting "ranlib command" + + -- TODO this side-effect doesn't belong here. Reading and parsing the settings + -- should be idempotent and accumulate no resources. + tmpdir <- liftIO $ getTemporaryDirectory + + touch_path <- getToolSetting "touch command" + + mkdll_prog <- getToolSetting "dllwrap command" + let mkdll_args = [] + + -- cpp is derived from gcc on all platforms + -- HACK, see setPgmP below. We keep 'words' here to remember to fix + -- Config.hs one day. + + + -- Other things being equal, as and ld are simply gcc + cc_link_args_str <- getSetting "C compiler link flags" + let as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_prog + ld_args = map Option (cc_args ++ words cc_link_args_str) + ld_r_prog <- getToolSetting "Merge objects command" + ld_r_args <- getSetting "Merge objects flags" + + -- We just assume on command line + lc_prog <- getSetting "LLVM llc command" + lo_prog <- getSetting "LLVM opt command" + lcc_prog <- getSetting "LLVM clang command" + + let iserv_prog = libexec "ghc-iserv" + + return $ Settings + { sGhcNameVersion = GhcNameVersion + { ghcNameVersion_programName = "ghc" + , ghcNameVersion_projectVersion = cProjectVersion + } + + , sFileSettings = FileSettings + { fileSettings_tmpDir = normalise tmpdir + , fileSettings_ghcUsagePath = ghc_usage_msg_path + , fileSettings_ghciUsagePath = ghci_usage_msg_path + , fileSettings_toolDir = mtool_dir + , fileSettings_topDir = top_dir + , fileSettings_globalPackageDatabase = globalpkgdb_path + } + + , sToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind + , toolSettings_ldSupportsBuildId = ldSupportsBuildId + , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldIsGnuLd = ldIsGnuLd + , toolSettings_ccSupportsNoPie = gccSupportsNoPie + + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (cpp_prog, cpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = cc_prog + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_lm = (ld_r_prog, map Option $ words ld_r_args) + , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) + , toolSettings_pgm_T = touch_path + , toolSettings_pgm_windres = windres_path + , toolSettings_pgm_libtool = libtool_path + , toolSettings_pgm_ar = ar_path + , toolSettings_pgm_otool = otool_path + , toolSettings_pgm_install_name_tool = install_name_tool_path + , toolSettings_pgm_ranlib = ranlib_path + , toolSettings_pgm_lo = (lo_prog,[]) + , toolSettings_pgm_lc = (lc_prog,[]) + , toolSettings_pgm_lcc = (lcc_prog,[]) + , toolSettings_pgm_i = iserv_prog + , toolSettings_opt_L = [] + , toolSettings_opt_P = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_F = [] + , toolSettings_opt_c = cc_args + , toolSettings_opt_cxx = cxx_args + , toolSettings_opt_a = [] + , toolSettings_opt_l = [] + , toolSettings_opt_lm = [] + , toolSettings_opt_windres = [] + , toolSettings_opt_lcc = [] + , toolSettings_opt_lo = [] + , toolSettings_opt_lc = [] + , toolSettings_opt_i = [] + + , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags + } + + , sTargetPlatform = platform + + -- Lots of uninitialized fields here. + , sPlatformMisc = PlatformMisc {} + , sPlatformConstants = PlatformConstants { pc_DYNAMIC_BY_DEFAULT = False } + + , sRawSettings = settingsList + } + +-- Stripped version of 'GHC.Settings.Platform.getTargetPlatform'. Arch info is +-- needed for CPP defines, the rest is irrelevant. +compatGetTargetPlatform + :: FilePath -> RawSettings -> Either String Platform +compatGetTargetPlatform settingsFile mySettings = do + let + readSetting :: (Show a, Read a) => String -> Either String a + readSetting = readSetting0 settingsFile mySettings + + targetArch <- readSetting "target arch" + targetOS <- readSetting "target os" + targetWordSize <- readSetting "target word size" + + pure $ Platform + { platformMini = PlatformMini + { platformMini_arch = targetArch + , platformMini_os = targetOS + } + , platformWordSize = targetWordSize + -- below is irrelevant + , platformByteOrder = LittleEndian + , platformUnregisterised = True + , platformHasGnuNonexecStack = False + , platformHasIdentDirective = False + , platformHasSubsectionsViaSymbols = False + , platformIsCrossCompiling = False + , platformLeadingUnderscore = False + , platformTablesNextToCode = False + } diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -9,26 +9,19 @@ import Data.Bifunctor import Data.Char import Data.Function -import Data.IORef import Data.List import Data.Maybe (mapMaybe) import Data.Time import Data.Time.Format.ISO8601 import GHC.Conc (getNumProcessors) import GHC.Data.Bag -import GHC.Data.FastString import GHC.Data.StringBuffer -import GHC.Driver.Main import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Types (HscEnv(..)) import GHC.Hs import GHC.Parser.Lexer -import GHC.Paths -import GHC.Platform -import GHC.SysTools import GHC.Types.SrcLoc -import GHC.Unit.Module.Env import GHC.Utils.Error import System.Directory import System.Environment @@ -42,20 +35,19 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.Foldable as F import qualified Data.Map.Strict as Map -import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Vector as V import qualified GHC import qualified GHC.Driver.Pipeline as DP -import qualified GHC.Parser as Parser import qualified GHC.Utils.Outputable as Out import GhcTags import GhcTags.Config.Args import GhcTags.Config.Project import GhcTags.CTag.Header +import GhcTags.GhcCompat import qualified GhcTags.CTag as CTag import qualified GhcTags.ETag as ETag @@ -392,51 +384,3 @@ headers = if null tHeaders then defaultHeaders else tHeaders - ----------------------------------------- - -runGhc :: Ghc a -> IO a -runGhc m = do - env <- liftIO $ do - mySettings <- initSysTools libdir - myLlvmConfig <- lazyInitLlvmConfig libdir - dflags <- threadSafeInitDynFlags (defaultDynFlags mySettings myLlvmConfig) - newHscEnv dflags - ref <- newIORef env - unGhc (GHC.withCleanupSession m) (Session ref) - where - threadSafeInitDynFlags dflags = do - let -- We can't build with dynamic-too on Windows, as labels before the - -- fork point are different depending on whether we are building - -- dynamically or not. - platformCanGenerateDynamicToo - = platformOS (targetPlatform dflags) /= OSMinGW32 - refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo - refNextTempSuffix <- newIORef 0 - refFilesToClean <- newIORef emptyFilesToClean - refDirsToClean <- newIORef Map.empty - refGeneratedDumps <- newIORef Set.empty - refRtldInfo <- newIORef Nothing - refRtccInfo <- newIORef Nothing - wrapperNum <- newIORef emptyModuleEnv - pure dflags - { canGenerateDynamicToo = refCanGenerateDynamicToo - , nextTempSuffix = refNextTempSuffix - , filesToClean = refFilesToClean - , dirsToClean = refDirsToClean - , generatedDumps = refGeneratedDumps - , nextWrapperNum = wrapperNum - , rtldInfo = refRtldInfo - , rtccInfo = refRtccInfo - } - -parseModule - :: FilePath - -> DynFlags - -> StringBuffer - -> ParseResult (Located HsModule) -parseModule filename flags buffer = - unP Parser.parseModule parseState - where - location = mkRealSrcLoc (mkFastString filename) 1 1 - parseState = mkPState flags buffer location