ghc-tags 1.10 → 1.11
raw patch · 13 files changed
+415/−141 lines, 13 filesdep −ghc-libdep ~basedep ~ghcdep ~ghc-boot
Dependencies removed: ghc-lib
Dependency ranges changed: base, ghc, ghc-boot
Files
- CHANGELOG.md +56/−0
- README.md +61/−19
- ghc-tags.cabal +6/−14
- src/GhcTags/CTag/Parser.hs +9/−1
- src/GhcTags/CTag/Utils.hs +6/−6
- src/GhcTags/Config/Args.hs +21/−12
- src/GhcTags/Config/Project.hs +85/−27
- src/GhcTags/ETag/Parser.hs +4/−4
- src/GhcTags/Ghc.hs +56/−25
- src/GhcTags/GhcCompat.hs +12/−0
- src/GhcTags/Tag.hs +7/−22
- src/GhcTags/Utils.hs +15/−0
- src/Main.hs +77/−11
CHANGELOG.md view
@@ -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.
README.md view
@@ -1,6 +1,6 @@ # ghc-tags -[](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster)+[](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster) [](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
ghc-tags.cabal view
@@ -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
src/GhcTags/CTag/Parser.hs view
@@ -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
src/GhcTags/CTag/Utils.hs view
@@ -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
src/GhcTags/Config/Args.hs view
@@ -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 "<source paths...>"
src/GhcTags/Config/Project.hs view
@@ -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]
src/GhcTags/ETag/Parser.hs view
@@ -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).
src/GhcTags/Ghc.hs view
@@ -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 {} = []
src/GhcTags/GhcCompat.hs view
@@ -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
src/GhcTags/Tag.hs view
@@ -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'
src/GhcTags/Utils.hs view
@@ -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)
src/Main.hs view
@@ -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 ()