diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,59 @@ +# ghc-tags-1.11 (2026-09-13) +* Generate a tag for each name that a pattern binding defines, e.g. `pairA` + and `pairB` in `(pairA, pairB) = ...`. Earlier versions skipped pattern + bindings. The tag points at the start of the pattern. +* Generate a tag for a standalone `deriving instance` declaration, with the + same kind as a class instance. +* Fix the tag of an associated type default, e.g. `type AT a = Maybe Int` in a + class body. Earlier versions read the name from the wrong side of the + equation and tagged the head of the right-hand side, `Maybe` in this + example. A jump to `Maybe` landed in the class, and `AT` had no tag for the + default. The tag now carries the name of the type family. +* Don't generate a tag for a `default` method signature in a class. Earlier + versions tagged it as a second class member with the same name. A jump to + the member then offered a line that is not its declaration. +* Read the configuration from `.ghc-tags.yaml` when `ghc-tags.yaml` doesn't + exist. When both files exist, `ghc-tags.yaml` is read and a warning names + the file in use. +* Recognise `module M (module M) where` as an export list that exports + everything. Earlier versions saw no matching name in such a list and marked + every tag with the ctags `file:` field. That field tells vim that the tag is + visible only inside its own file. +* Reject a `--threads` value below 1 with a usage error. Earlier versions ended + the run with an uncaught error from `setNumCapabilities`. +* Enable `BinaryLiterals`, `LinearTypes` and `QualifiedDo` by default, and + `MultilineStrings` with GHC 9.12 and later. +* Ignore a flag in an `OPTIONS_GHC` pragma that the bundled GHC API doesn't + know. Earlier versions reported an error and dropped all the tags of the file. + This made a source tree that is built with a newer compiler hard to index. +* Recover from a broken tags file instead of crashing. A header comment without + its closing slash and a byte that is not valid UTF-8 both ended the run with + an uncaught exception. +* Reject a tags file that is only partly readable. Earlier versions stopped at + the first bad line and dropped every tag after it without a word, and the + stored modification times stopped those tags from ever coming back. The bad + line is now reported and all the source files are scanned again. +* Decode source lines and names leniently. A byte that is not valid UTF-8 in a + source file or in its name no longer crashes the run. +* If the configuration file cannot be parsed, exit with a failure code. The + error message now goes to standard error. Earlier versions printed the message + to standard output and exited with success. +* Normalise `exclude_paths` before matching them against source paths. An entry + that begins with `./` or ends with a path separator now excludes the path it + names. +* Fix the kind characters of type families in ctags. An uppercase character now + always marks the family and a lowercase one the instance: `T` and `t` for a + type family, `D` and `d` for a data type family. Reading a tags file no longer + swaps `T` with `t`, and a data type family now gets `D` instead of `d`. Delete + the old tags file to regenerate it from scratch. +* Add support for GHC 9.14 and drop support for GHC 9.8. +* Accept `GHC2021` and `GHC2024` as values of the `language` configuration key. +* Support disabling a language extension in the configuration file by prefixing + its name with `No`, e.g. `NoStarIsType`. +* Drop the `ghc-lib` dependency and the `ghc-lib` flag. The parser now comes + from the `ghc` library of the compiler that builds `ghc-tags`. The supported + syntax is the syntax of that compiler. + # ghc-tags-1.10 (2025-11-19) * Add support for GHC 9.12 and drop support for GHC 9.6. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # 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) +[![Build Status](https://github.com/arybczak/ghc-tags/actions/workflows/ci.yml/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 @@ -28,15 +28,19 @@ etags) or `ghc-tags -c` (for ctags) in the root directory of the project. For more complicated projects you need to create the configuration file -(`ghc-tags.yaml` by default). It can contain the following keys: +(`ghc-tags.yaml` or `.ghc-tags.yaml` by default, the first one that exists is +read and a warning is printed when both exist). It can contain the following +keys: * `source_paths` - a list of paths for `ghc-tags` to process. Directories are traversed recursively. * `exclude_paths` - a list of paths for `ghc-tags` to exclude from processing. -* `language` - the flavour of Haskell, either `Haskell98` or `Haskell2010`. -* `extensions` - a list of GHC language extensions to enable when parsing. Note - that GHC needs much less extensions for parsing alone, so you should almost - never need to override this. +* `language` - the flavour of Haskell, one of `Haskell98`, `Haskell2010`, + `GHC2021` or `GHC2024`. +* `extensions` - a list of GHC language extensions to enable when parsing. A + `No` prefix disables the extension instead, e.g. `NoStarIsType`. Note that GHC + needs much less extensions for parsing alone, so you should almost never need + to override this. * `cpp_includes` - include paths for the C pre-processor. * `cpp_options` - other options for the C pre-processor, e.g. defines (usually undefined `MIN_VERSION_x` macros will go here). @@ -46,7 +50,7 @@ **Note:** it is possible to specify multiple project configurations in the configuration file by separating them with `---`. For example, here is a -configuration for GHC on Linux (compiler, utils and base): +configuration for GHC on Linux (the compiler, the boot libraries and haddock): ```yaml source_paths: @@ -55,27 +59,33 @@ cpp_includes: - _build/stage1/compiler/build - compiler -- includes/dist-derivedconstants/header --- source_paths: - libraries/base +- libraries/ghc-internal exclude_paths: -- libraries/base/GHC/Conc/POSIX/Const.hsc -- libraries/base/GHC/Event/Windows.hsc -- libraries/base/GHC/Event/Windows/ConsoleEvent.hsc -- libraries/base/GHC/Event/Windows/FFI.hsc -- libraries/base/GHC/IO/Windows/Handle.hsc -- libraries/base/System/CPUTime/Windows.hsc +- libraries/base/src/System/CPUTime/Javascript.hs +- libraries/base/src/System/CPUTime/Windows.hsc - libraries/base/tests +- libraries/ghc-internal/src/GHC/Internal/Conc/POSIX/Const.hsc +- libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc +- libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc +- libraries/ghc-internal/src/GHC/Internal/Event/Windows/FFI.hsc +- libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc +- libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs cpp_includes: -- _build/stage1/libraries/base/build/include -- includes -- libraries/base/include +- _build/stage1/libraries/ghc-internal/build/include +- _build/stage1/rts/build/include +- libraries/ghc-internal/include +- rts/include +cpp_options: +- -DBIGNUM_GMP + --- source_paths: @@ -93,13 +103,45 @@ - libraries/ghc-boot - libraries/ghc-boot-th - libraries/ghc-compact -- libraries/ghc-heap +- libraries/ghc-experimental - libraries/ghc-prim +- libraries/ghc-platform +- libraries/template-haskell exclude_paths: - libraries/ghc-compact/tests -- libraries/ghc-heap/tests - libraries/ghc-prim/tests + +--- + +source_paths: +- libraries/ghc-heap + +cpp_includes: +- _build/stage1/rts/build/include +- rts/include + +cpp_options: +- -DMIN_TOOL_VERSION_ghc(x,y,z)=1 + +exclude_paths: +- libraries/ghc-heap/tests + +--- + +source_paths: +- utils/haddock/haddock +- utils/haddock/haddock-api +- utils/haddock/haddock-library +- utils/haddock/driver + +cpp_includes: +- _build/stage1/rts/build/include +- rts/include + +exclude_paths: +- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs +- utils/haddock/haddock-api/src/Haddock/Types.hs ``` ## Acknowledgments diff --git a/ghc-tags.cabal b/ghc-tags.cabal --- a/ghc-tags.cabal +++ b/ghc-tags.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-tags -version: 1.10 +version: 1.11 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,26 +14,16 @@ README.md homepage: https://github.com/arybczak/ghc-tags bug-reports: https://github.com/arybczak/ghc-tags/issues -tested-with: GHC == { 9.8.4, 9.10.3, 9.12.2 } +tested-with: GHC == { 9.10.3, 9.12.4, 9.14.1 } source-repository head type: git location: https://github.com/arybczak/ghc-tags -flag ghc-lib - default: False - manual: True - description: Use ghc-lib even when compiling with compatible GHC version. - executable ghc-tags - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-A4m - - if !flag(ghc-lib) && impl(ghc == 9.12.*) - build-depends: ghc, ghc-boot - else - build-depends: ghc-lib == 9.12.* + ghc-options: -Wall -Wunused-packages -threaded -rtsopts - build-depends: base >=4.19 && <4.22 + build-depends: base >=4.20 && <4.23 , aeson >= 2.0.0.0 , async >= 2.2.5 , attoparsec @@ -42,6 +32,8 @@ , deepseq , directory , filepath + , ghc >= 9.10 && < 9.15 + , ghc-boot >= 9.10 && < 9.15 , ghc-paths , stm , optparse-applicative diff --git a/src/GhcTags/CTag/Parser.hs b/src/GhcTags/CTag/Parser.hs --- a/src/GhcTags/CTag/Parser.hs +++ b/src/GhcTags/CTag/Parser.hs @@ -20,6 +20,7 @@ import GhcTags.Tag import GhcTags.CTag.Header import GhcTags.CTag.Utils +import qualified GhcTags.Utils as Utils @@ -111,6 +112,7 @@ parseTags = (\headers tags -> (headers, Map.fromListWith (++) $ map sndList tags)) <$> many parseHeader <*> many parseTag + <* Utils.endOfInput where sndList (file, tag) = (file, [tag]) @@ -182,8 +184,14 @@ parseComment :: Parser Text parseComment = AT.char '/' - *> (Text.init <$> AT.takeWhile notNewLine) + *> (dropEndSlash <$> AT.takeWhile notNewLine) <* endOfLine + where + -- The comment ends with a slash, but a foreign tags file can omit it. + dropEndSlash :: Text -> Text + dropEndSlash t = case Text.stripSuffix "/" t of + Just t' -> t' + Nothing -> t diff --git a/src/GhcTags/CTag/Utils.hs b/src/GhcTags/CTag/Utils.hs --- a/src/GhcTags/CTag/Utils.hs +++ b/src/GhcTags/CTag/Utils.hs @@ -25,8 +25,8 @@ TkTypeClassInstance -> Just 'i' TkTypeFamily -> Just 'T' TkTypeFamilyInstance -> Just 't' - TkDataTypeFamily -> Just 'd' - TkDataTypeFamilyInstance -> Just 'D' + TkDataTypeFamily -> Just 'D' + TkDataTypeFamilyInstance -> Just 'd' TkForeignImport -> Just 'I' TkForeignExport -> Just 'E' @@ -49,10 +49,10 @@ 'C' -> TkTypeClass 'm' -> TkTypeClassMember 'i' -> TkTypeClassInstance - 't' -> TkTypeFamily - 'T' -> TkTypeFamilyInstance - 'd' -> TkDataTypeFamily - 'D' -> TkDataTypeFamilyInstance + 'T' -> TkTypeFamily + 't' -> TkTypeFamilyInstance + 'D' -> TkDataTypeFamily + 'd' -> TkDataTypeFamilyInstance 'I' -> TkForeignImport 'E' -> TkForeignExport 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 @@ -1,6 +1,8 @@ {-# LANGUAGE ApplicativeDo #-} module GhcTags.Config.Args where +import Control.Monad +import Data.List import Data.Version import Options.Applicative @@ -15,7 +17,7 @@ -- | Get source paths from the configuration file or command line arguments. data SourcePaths = SourceArgs [FilePath] - | ConfigFile FilePath + | ConfigFile (Maybe FilePath) deriving Show data Args = Args @@ -57,20 +59,27 @@ <> value "" <> showDefaultWith (const "TAGS (etags) or tags (ctags)") - configFile :: Parser FilePath - configFile = strOption $ long "config" + configFile :: Parser (Maybe FilePath) + configFile = optional . strOption $ long "config" <> metavar "FILE" - <> value "ghc-tags.yaml" - <> showDefaultWith id - <> help "Configuration file" + <> help ("Configuration file (default: " + ++ intercalate ", then " defaultConfigFiles ++ ")") threads :: Parser Int - threads = option auto $ long "threads" - <> short 'j' - <> metavar "NUMBER" - <> value defaultThreads - <> showDefault - <> help "Number of threads to use" + threads = option positive $ long "threads" + <> short 'j' + <> metavar "NUMBER" + <> value defaultThreads + <> showDefault + <> help "Number of threads to use" + where + -- Zero deadlocks the queue and 'setNumCapabilities' rejects anything + -- below one, so stop such a value here with a readable message. + positive :: ReadM Int + positive = do + n <- auto + when (n < 1) $ readerError "the number of threads must be at least 1" + pure n sourcePaths :: Parser [FilePath] sourcePaths = some . argument str $ metavar "" diff --git a/src/GhcTags/Config/Project.hs b/src/GhcTags/Config/Project.hs --- a/src/GhcTags/Config/Project.hs +++ b/src/GhcTags/Config/Project.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} module GhcTags.Config.Project where +import Control.Monad import Data.Aeson import Data.Aeson.Types import Data.Maybe @@ -10,6 +12,7 @@ import GHC.LanguageExtensions import GHC.Settings import System.Directory +import System.IO import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as K import qualified Data.ByteString.Char8 as BS @@ -18,11 +21,17 @@ import qualified Data.Yaml as Y import qualified Data.Yaml.Pretty as Y +-- | A language extension to either enable or disable. +data ExtensionFlag + = EnableExtension Extension + | DisableExtension Extension + deriving (Eq, Show) + data ProjectConfig = ProjectConfig { pcSourcePaths :: [FilePath] , pcExcludePaths :: [FilePath] , pcLanguage :: Language - , pcExtensions :: [Extension] + , pcExtensions :: [ExtensionFlag] , pcCppIncludes :: [FilePath] , pcCppOptions :: [String] } @@ -36,7 +45,9 @@ , "dist-newstyle" ] , pcLanguage = Haskell2010 - , pcExtensions = [ BangPatterns + , pcExtensions = map EnableExtension + [ BangPatterns + , BinaryLiterals , BlockArguments , CApiFFI , ExplicitForAll @@ -44,11 +55,16 @@ , GADTSyntax , ImportQualifiedPost , LambdaCase + , LinearTypes , MagicHash +#if __GLASGOW_HASKELL__ >= 912 + , MultilineStrings +#endif , MultiWayIf , NumericUnderscores , OverloadedLabels , PatternSynonyms + , QualifiedDo , QuasiQuotes , TemplateHaskellQuotes , TypeApplications @@ -58,14 +74,35 @@ , pcCppOptions = [] } -getProjectConfigs :: FilePath -> IO [ProjectConfig] -getProjectConfigs file = doesFileExist file >>= \case - True -> Y.decodeAllFileEither file >>= \case +-- | Configuration files probed when '--config' is not given, in the order of +-- precedence. +defaultConfigFiles :: [FilePath] +defaultConfigFiles = ["ghc-tags.yaml", ".ghc-tags.yaml"] + +-- | Read the project configurations from the given file or, when there is +-- none, from the first of 'defaultConfigFiles' that exists. Return 'Nothing' +-- when the file exists and cannot be parsed. +getProjectConfigs :: Maybe FilePath -> IO (Maybe [ProjectConfig]) +getProjectConfigs mfile = resolve >>= \case + Nothing -> pure $ Just [defaultProjectConfig] + Just file -> Y.decodeAllFileEither file >>= \case Left e -> do - putStrLn $ file ++ ": " ++ Y.prettyPrintParseException e - pure [] - Right pcs -> pure pcs - False -> pure [defaultProjectConfig] + hPutStrLn stderr $ file ++ ": " ++ Y.prettyPrintParseException e + pure Nothing + Right pcs -> pure $ Just pcs + where + resolve :: IO (Maybe FilePath) + resolve = case mfile of + Just file -> doesFileExist file >>= \case + True -> pure $ Just file + False -> pure Nothing + Nothing -> filterM doesFileExist defaultConfigFiles >>= \case + [] -> pure Nothing + file : others -> do + forM_ others $ \other -> hPutStrLn stderr $ + "Warning: both " ++ file ++ " and " ++ other + ++ " exist, reading " ++ file + pure $ Just file ppProjectConfig :: ProjectConfig -> String ppProjectConfig = BS.unpack . Y.encodePretty conf @@ -83,7 +120,12 @@ where applyLanguage fs = lang_set fs (Just pcLanguage) - applyExtensions fs = foldl' xopt_set fs pcExtensions + applyExtensions fs = foldl' setExtension fs pcExtensions + where + setExtension :: DynFlags -> ExtensionFlag -> DynFlags + setExtension acc = \case + EnableExtension ext -> xopt_set acc ext + DisableExtension ext -> xopt_unset acc ext applyCppIncludes fs = fs { includePaths = addGlobalInclude (includePaths fs) pcCppIncludes @@ -106,7 +148,7 @@ [ "source_paths" .= pcSourcePaths , "exclude_paths" .= pcExcludePaths , "language" .= show pcLanguage - , "extensions" .= map showExtension pcExtensions + , "extensions" .= map showExtensionFlag pcExtensions , "cpp_includes" .= pcCppIncludes , "cpp_options" .= pcCppOptions ] @@ -120,7 +162,7 @@ parseLanguage v "language" pcExtensions <- def pcExtensions <$> explicitParseFieldMaybe' - (listParser parseExtension) v + (listParser parseExtensionFlag) v "extensions" pcCppIncludes <- def pcCppIncludes <$> v .:! "cpp_includes" pcCppOptions <- def pcCppOptions <$> v .:! "cpp_options" @@ -140,11 +182,11 @@ Nothing -> fail $ "unknown language: " ++ T.unpack t parseLanguage inv = typeMismatch "String" inv - parseExtension :: Value -> Parser Extension - parseExtension (String t) = case readExtension t of + parseExtensionFlag :: Value -> Parser ExtensionFlag + parseExtensionFlag (String t) = case readExtensionFlag t of Just ext -> pure ext Nothing -> fail $ "unknown extension: " ++ T.unpack t - parseExtension inv = typeMismatch "String" inv + parseExtensionFlag inv = typeMismatch "String" inv parseJSON v = prependFailure "parsing project configuration failed: " $ typeMismatch "Object" v @@ -162,18 +204,34 @@ -- Utils readLanguage :: T.Text -> Maybe Language -readLanguage "Haskell98" = Just Haskell98 -readLanguage "Haskell2010" = Just Haskell2010 -readLanguage _ = Nothing +readLanguage = \case + "Haskell98" -> Just Haskell98 + "Haskell2010" -> Just Haskell2010 + "GHC2021" -> Just GHC2021 + "GHC2024" -> Just GHC2024 + _ -> Nothing -showExtension :: Extension -> T.Text -showExtension Cpp = "CPP" -showExtension ext = T.pack $ show ext +showExtensionFlag :: ExtensionFlag -> T.Text +showExtensionFlag = \case + EnableExtension ext -> showExtension ext + DisableExtension ext -> "No" <> showExtension ext + where + showExtension :: Extension -> T.Text + showExtension Cpp = "CPP" + showExtension ext = T.pack $ show ext -readExtension :: T.Text -> Maybe Extension -readExtension ext = ext `Map.lookup` exts +-- | Parse an extension name. A @No@ prefix disables the extension instead of +-- enabling it. The prefix is only stripped if the full name is not an extension +-- itself, so @NondecreasingIndentation@ keeps its meaning. +readExtensionFlag :: T.Text -> Maybe ExtensionFlag +readExtensionFlag name = case readExtension name of + Just ext -> Just $ EnableExtension ext + Nothing -> DisableExtension <$> (readExtension =<< T.stripPrefix "No" name) where - exts :: Map.Map T.Text Extension - exts = Map.fromList . (("CPP", Cpp) :) - . map (\e -> (T.pack $ show e, e)) - $ filter (/= Cpp) [minBound..maxBound] + readExtension :: T.Text -> Maybe Extension + readExtension ext = ext `Map.lookup` exts + where + exts :: Map.Map T.Text Extension + exts = Map.fromList . (("CPP", Cpp) :) + . map (\e -> (T.pack $ show e, e)) + $ filter (/= Cpp) [minBound..maxBound] diff --git a/src/GhcTags/ETag/Parser.hs b/src/GhcTags/ETag/Parser.hs --- a/src/GhcTags/ETag/Parser.hs +++ b/src/GhcTags/ETag/Parser.hs @@ -21,10 +21,10 @@ -- parseTagsFile :: Text -> IO (Either String ETagMap) -parseTagsFile = - fmap AT.eitherResult - . AT.parseWith (pure mempty) - (Map.fromList <$> many parseTagFileSection) +parseTagsFile = fmap AT.eitherResult . AT.parseWith (pure mempty) parseTags + where + parseTags :: Parser ETagMap + parseTags = Map.fromList <$> many parseTagFileSection <* Utils.endOfInput -- | Parse tags from a single file (a single section in etags file). diff --git a/src/GhcTags/Ghc.hs b/src/GhcTags/Ghc.hs --- a/src/GhcTags/Ghc.hs +++ b/src/GhcTags/Ghc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | Generate tags from @'HsModule' 'GhcPs'@ representation. -- module GhcTags.Ghc @@ -17,6 +18,7 @@ import GHC.Hs.Extension import GHC.Hs.ImpExp import GHC.Hs.Type hiding (hsSigWcType) +import GHC.Hs.Utils import GHC.Parser.Annotation import GHC.Types.Name (nameOccName, occNameFS) import GHC.Types.Name.Reader @@ -158,12 +160,14 @@ -- -- * /module name/ -- * /top level terms/ +-- * /pattern bindings/ -- * /data types/ -- * /record fields/ -- * /type synonyms/ -- * /type classes/ -- * /type class members/ -- * /type class instances/ +-- * /standalone deriving declarations/ -- * /type families/ -- * /type family instances/ -- * /data type families/ @@ -177,7 +181,17 @@ ++ hsDeclsToGhcTags mies hsmodDecls where mies :: Maybe [IE GhcPs] - mies = map unLoc . unLoc <$> hsmodExports + mies = case map unLoc . unLoc <$> hsmodExports of + -- `module M (module M) where` exports everything M defines, but the list + -- names no entity, so looking a name up in it always fails. 'isExported' + -- takes an absent list to mean that everything is exported. + Just ies | any exportsSelf ies -> Nothing + exports -> exports + where + exportsSelf :: IE GhcPs -> Bool + exportsSelf = \case + IEModuleContents _ (L _ name) -> Just name == (unLoc <$> hsmodName) + _ -> False mkModNameTag :: LocatedA ModuleName -> GhcTag mkModNameTag (L l modName) = @@ -269,16 +283,11 @@ ++ ((\a -> mkFamilyDeclTags decLoc a (Just tcdLName)) . unLoc) `mapMaybe` tcdATs -- associated type defaults (data type families, type families -- (open or closed) - ++ foldr - (\(L _ decl@(TyFamInstDecl { tfid_eqn })) tags' -> - case tfid_eqn of - FamEqn { feqn_rhs = L _ hsType } -> - case hsTypeTagName hsType of - -- TODO: add a `default` field - Just a -> mkGhcTag' decLoc a (GtkTypeFamilyInstance decl) : tags' - Nothing -> tags' - ) - [] tcdATDefs + ++ map + (\(L _ decl@TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon } }) -> + mkGhcTagForMember decLoc feqn_tycon tcdLName + (GtkTypeFamilyInstance decl)) + tcdATDefs ++ tags -- Instance declarations @@ -321,8 +330,9 @@ Nothing -> tags Just tag -> tag : tags - -- deriving declaration - DerivD {} -> tags + -- standalone deriving declaration + DerivD _ DerivDecl { deriv_type = HsWC { hswc_body = L _ HsSig { sig_body } } } -> + maybe tags (: tags) (mkLHsTypeTag decLoc sig_body) -- value declaration ValD _ hsBind -> mkHsBindLRTags decLoc hsBind ++ tags @@ -399,8 +409,13 @@ mkHsConDeclGADTDetails decLoc tyName (RecConGADT _ (L _ fields)) = foldr f [] fields where +#if __GLASGOW_HASKELL__ >= 914 + f :: LHsConDeclRecField GhcPs -> [GhcTag] -> [GhcTag] + f (L _ HsConDeclRecField { cdrf_names }) ts = ts ++ map g cdrf_names +#else f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag] f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names +#endif g :: LFieldOcc GhcPs -> GhcTag g (L _ FieldOcc { foLabel }) = @@ -415,8 +430,13 @@ mkHsConDeclH98Details decLoc tyName (RecCon (L _ fields)) = foldr f [] fields where +#if __GLASGOW_HASKELL__ >= 914 + f :: LHsConDeclRecField GhcPs -> [GhcTag] -> [GhcTag] + f (L _ HsConDeclRecField { cdrf_names }) ts = ts ++ map g cdrf_names +#else f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag] f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names +#endif g :: LFieldOcc GhcPs -> GhcTag g (L _ FieldOcc { foLabel }) = @@ -436,12 +456,14 @@ in mkGhcTag' decLoc fun_id GtkFunction : concatMap (mkHsLocalBindsTags decLoc) binds - -- TODO - -- This is useful fo generating tags for - -- ```` - -- Just x = lhs - -- ``` - PatBind {} -> [] + PatBind { pat_lhs, pat_rhs } -> + -- 'collectPatBinders' drops the location of each binder, so every + -- tag points at the start of the pattern. + let binder :: RdrName -> GhcTag + binder name = + mkGhcTag' decLoc (L (noAnnSrcSpan (getLocA pat_lhs)) name) GtkTerm + in map binder (collectPatBinders CollNoDictBinders pat_lhs) + ++ mkHsLocalBindsTags decLoc (grhssLocalBinds pat_rhs) -- According to the GHC documentation VarBinds are introduced by the -- type checker, so ghc-tags will never encounter them. @@ -450,16 +472,22 @@ PatSynBind _ PSB { psb_id, psb_args } -> mkGhcTag' decLoc psb_id GtkPatternSynonym : case psb_args of RecCon fields -> - let fldLabel = foLabel . recordPatSynField + let fldLabel fld = case recordPatSynField fld of + FieldOcc _ label -> label + XFieldOcc _ -> error "can't happen" in map (\fld -> mkGhcTag' decLoc (fldLabel fld) GtkRecordField) fields _ -> [] mkClsMemberTags :: SrcSpan -> LocatedN RdrName -> Sig GhcPs -> [GhcTag] - mkClsMemberTags decLoc clsName (ClassOpSig _ _ lhs hsSigWcType) = - (\n -> mkGhcTagForMember decLoc n clsName $ - GtkTypeClassMember HsWC { hswc_ext = NoExtField - , hswc_body = hsSigWcType - }) `map` lhs + mkClsMemberTags decLoc clsName (ClassOpSig _ isDefault lhs hsSigWcType) + -- A default signature (`default meth :: ...`) constrains the default + -- implementation, it doesn't declare the member. + | isDefault = [] + | otherwise = + (\n -> mkGhcTagForMember decLoc n clsName $ + GtkTypeClassMember HsWC { hswc_ext = NoExtField + , hswc_body = hsSigWcType + }) `map` lhs mkClsMemberTags _ _ _ = [] @@ -479,6 +507,9 @@ mkSigTags _ InlineSig {} = [] -- SPECIALISE pragmas mkSigTags _ SpecSig {} = [] +#if __GLASGOW_HASKELL__ >= 914 + mkSigTags _ SpecSigE {} = [] +#endif mkSigTags _ SpecInstSig {} = [] -- MINIMAL pragma mkSigTags _ MinimalSig {} = [] diff --git a/src/GhcTags/GhcCompat.hs b/src/GhcTags/GhcCompat.hs --- a/src/GhcTags/GhcCompat.hs +++ b/src/GhcTags/GhcCompat.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-missing-fields #-} module GhcTags.GhcCompat ( runGhc @@ -28,6 +29,10 @@ import qualified GHC import qualified GHC.Parser as Parser +#if __GLASGOW_HASKELL__ >= 914 +import GHC.Unit.Types +#endif + parseModule :: FilePath -> DynFlags @@ -168,6 +173,13 @@ , fileSettings_topDir = top_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } + +#if __GLASGOW_HASKELL__ >= 914 + , sUnitSettings = UnitSettings + { + unitSettings_baseUnitId = stringToUnitId "" + } +#endif , sToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind diff --git a/src/GhcTags/Tag.hs b/src/GhcTags/Tag.hs --- a/src/GhcTags/Tag.hs +++ b/src/GhcTags/Tag.hs @@ -89,25 +89,8 @@ -- preserve information from parsed tags files which were not created by -- `ghc-tags-plugin' -- --- * 'TkModule' - @`@ --- * 'TkTerm' - @`@ --- * 'TkFunction' - @λ@ --- * 'TkTypeConstructor' - @Λ@ --- * 'TkDataConstructor' - @c@ --- * 'TkGADTConstructor' - @g@ --- * 'TkRecordField' - @r@ --- * 'TkTypeSynonym' - @≡@ --- * 'TkTypeSignature' - @⊢@ --- * 'TkPatternSynonym' - @p@ --- * 'TkTypeClass' - @C@ --- * 'TkTypeClassMember' - @m@ --- * 'TkTypeClassInstance' - @i@ --- * 'TkTypeFamily' - @f@ --- * 'TkTypeFamilyInstance' - @F@ --- * 'TkDataTypeFamily' - @d@ --- * 'TkDataTypeFamilyInstance' - @D@ --- * 'TkForeignImport' - @I@ --- * 'TkForeignExport' - @E@ +-- 'GhcTags.CTag.Utils.tagKindToChar' and 'GhcTags.CTag.Utils.charToTagKind' +-- define the character of each kind. -- data TagKind (tt :: TagType) where TkModule :: TagKind tt @@ -341,9 +324,11 @@ } where - fileName = TagFileName . Text.decodeUtf8 . bytesFS . srcSpanFile + -- A file name is not necessarily valid UTF-8, so a strict decoder would + -- throw and take the whole run down. + fileName = TagFileName . Text.decodeUtf8Lenient . bytesFS . srcSpanFile - tagName = Text.decodeUtf8 gtTag + tagName = Text.decodeUtf8Lenient gtTag fromGhcTagKind :: GhcTagKind -> TagKind tt fromGhcTagKind = \case @@ -386,7 +371,7 @@ TagFields $ case gtFFI of Nothing -> mempty - Just ffi -> [TagField "ffi" $ Text.decodeUtf8 ffi] + Just ffi -> [TagField "ffi" $ Text.decodeUtf8Lenient ffi] -- 'TagFields' from 'GhcTagKind' diff --git a/src/GhcTags/Utils.hs b/src/GhcTags/Utils.hs --- a/src/GhcTags/Utils.hs +++ b/src/GhcTags/Utils.hs @@ -3,8 +3,13 @@ module GhcTags.Utils ( endOfLine , notNewLine + , endOfInput ) where +import Control.Monad +import qualified Data.Attoparsec.Text as AT +import qualified Data.Text as T + -- | Platform dependend eol: -- -- * windows "CRNL" @@ -23,3 +28,13 @@ notNewLine :: Char -> Bool notNewLine = \x -> x /= '\n' && x /= '\r' + +-- | Fail unless all the input is consumed. A tags file that is only partly +-- readable is rejected as a whole, because otherwise every tag after the first +-- bad line is lost without a word. +-- +endOfInput :: AT.Parser () +endOfInput = do + rest <- AT.takeText + unless (T.null rest) . fail $ + "unexpected input: " ++ show (T.takeWhile (/= '\n') rest) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -18,11 +18,13 @@ import GHC.Data.Bag import GHC.Data.StringBuffer import GHC.Driver.Env.Types +import GHC.Driver.Errors.Types import GHC.Driver.Monad import GHC.Driver.Pipeline import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Hs +import GHC.Parser.Errors.Types import GHC.Parser.Lexer import GHC.Types.Error import GHC.Types.SrcLoc @@ -70,11 +72,19 @@ $ Concurrently (processFiles (pcSourcePaths pc) >> terminateWorkers) : replicate threads (Concurrently worker) where + -- Both sides of the exclusion test go through the same normalisation, so + -- that "./dist", "dist/" and "dist" mean the same directory. + normalisePath :: FilePath -> FilePath + normalisePath = dropTrailingPathSeparator . normalise + + excludePaths :: Set.Set FilePath + excludePaths = Set.fromList . map normalisePath $ pcExcludePaths pc + -- Walk a list of paths recursively and process eligible source files. processFiles :: [String] -> IO () processFiles = mapM_ $ \origPath -> do - let path = normalise origPath - unless (path `elem` pcExcludePaths pc) $ do + let path = normalisePath origPath + unless (path `Set.member` excludePaths) $ do doesDirectoryExist path >>= \case True -> do paths <- map (path ) <$> listDirectory path @@ -123,7 +133,7 @@ where processFile :: HscEnv -> FilePath -> HsFileType -> UTCTime -> IO () processFile env rawFile hsType mtime = withHsFile rawFile hsType $ \hsFile -> do - handle showErr $ preprocess env hsFile Nothing Nothing >>= \case + handle showErr $ preprocessFile hsFile >>= \case Left errs -> report (hsc_dflags env) (getMessages errs) Right (flags, file) -> do --when (file /= rawFile) $ do @@ -154,6 +164,47 @@ | msg <- pprMsgEnvelopeBagWithLocDefault msgs ] + -- GHC rejects a file when an OPTIONS_GHC pragma contains a flag + -- that the linked ghc library doesn't know, e.g. when the source + -- tree is built with a newer compiler. Such flags don't influence + -- tag generation, so blank them out and preprocess the file again. + preprocessFile + :: FilePath + -> IO (Either DriverMessages (DynFlags, FilePath)) + preprocessFile file = preprocess env file Nothing Nothing >>= \case + Left errs + | flagSpans@(_ : _) <- unknownFlagSpans errs -> do + content <- T.decodeUtf8Lenient <$> BS.readFile file + let buffer = stringToStringBuffer . T.unpack $ blankSpans flagSpans content + preprocess env file (Just buffer) Nothing + result -> pure result + + unknownFlagSpans :: DriverMessages -> [RealSrcSpan] + unknownFlagSpans errs = flip mapMaybe (bagToList $ getMessages errs) $ \msg -> + case (errMsgDiagnostic msg, errMsgSpan msg) of + (DriverPsHeaderMessage (PsHeaderMessage PsErrUnknownOptionsPragma{}), RealSrcSpan s _) + | srcSpanStartLine s == srcSpanEndLine s -> Just s + _ -> Nothing + + -- Overwrite the spans with spaces so that the line and column + -- numbers of the rest of the file stay the same. + blankSpans :: [RealSrcSpan] -> T.Text -> T.Text + blankSpans flagSpans = T.unlines . zipWith blankLine [1 ..] . T.lines + where + blankLine :: Int -> T.Text -> T.Text + blankLine lineNo line = + foldl' blank line $ filter ((== lineNo) . srcSpanStartLine) flagSpans + + -- Leave the line alone if the span doesn't point at a flag, as + -- then the column numbers don't match the decoded content. + blank :: T.Text -> RealSrcSpan -> T.Text + blank line s + | "-" `T.isPrefixOf` flag = before <> T.replicate (T.length flag) " " <> after + | otherwise = line + where + (before, rest) = T.splitAt (srcSpanStartCol s - 1) line + (flag, after) = T.splitAt (srcSpanEndCol s - srcSpanStartCol s) rest + -- Alex and Hsc files need to be preprocessed before going into GHC. withHsFile :: FilePath -> HsFileType -> (FilePath -> IO ()) -> IO () withHsFile file hsType k = case hsType of @@ -186,7 +237,9 @@ pcs <- case aSourcePaths args of SourceArgs paths -> pure [defaultProjectConfig { pcSourcePaths = paths }] - ConfigFile configFile -> getProjectConfigs configFile + ConfigFile configFile -> getProjectConfigs configFile >>= \case + Just pcs -> pure pcs + Nothing -> exitFailure when (not $ null pcs) $ do wd <- initWorkerData args (aThreads args) @@ -274,17 +327,29 @@ , tTags :: Map.Map TagFileName [Tag tt] } +-- | Like 'try', but let asynchronous exceptions through. A tags file that +-- cannot be read must not stop the run, whatever the reason is. +trySync :: IO a -> IO (Either SomeException a) +trySync m = try m >>= \case + Right a -> pure $ Right a + Left err -> case fromException err of + Just (SomeAsyncException _) -> throwIO err + Nothing -> pure $ Left err + readTags :: forall tt. SingTagType tt -> FilePath -> IO DirtyTags readTags tt tagsFile = doesFileExist tagsFile >>= \case False -> pure newDirtyTags True -> do - res <- tryIOError $ parseTagsFile . T.decodeUtf8 =<< BS.readFile tagsFile + res <- trySync $ do + parsed <- parseTagsFile . T.decodeUtf8Lenient =<< BS.readFile tagsFile + -- Full evaluation decreases performance variation. It also keeps a + -- failure of the parser inside 'trySync'. + evaluate $ force parsed case res of - Right (Right (headers, tags)) -> - -- full evaluation decreases performance variation - deepseq headers `seq` deepseq tags `seq` pure DirtyTags + Right (Right (headers, tags)) -> pure DirtyTags { dtKind = tt - , dtHeaders = headers , dtTags = Map.map (Updated False . Set.fromList) tags + , dtHeaders = headers + , dtTags = Map.map (Updated False . Set.fromList) tags } -- reading failed Left err -> do @@ -392,7 +457,8 @@ line <- fileLines V.!? (lineNo - 1) let TagFields fields = tagFields tag -- Ex mode forward search command. Slashes need to be escaped. - exCommand = T.concat ["/^", T.replace "/" "\\/" $ T.decodeUtf8 line, "$/"] + exCommand = T.concat + ["/^", T.replace "/" "\\/" $ T.decodeUtf8Lenient line, "$/"] pure tag { tagAddr = TagCommand $ ExCommand exCommand , tagFields = TagFields $ TagField "line" (T.pack $ show lineNo) : fields @@ -423,7 +489,7 @@ { tagAddr = TagLineOff lineNo offset , tagDefinition = -- Prevent weird characters from ending up in the TAGS file. - TagDefinition . T.takeWhile isPrint $ T.decodeUtf8 line + TagDefinition . T.takeWhile isPrint $ T.decodeUtf8Lenient line } writeTags :: FilePath -> Tags -> IO ()