ghc-tags 1.3 → 1.4
raw patch · 8 files changed
+114/−94 lines, 8 filesdep −unordered-containersdep ~aesondep ~basedep ~ghc-lib
Dependencies removed: unordered-containers
Dependency ranges changed: aeson, base, ghc-lib
Files
- CHANGELOG.md +6/−0
- README.md +3/−1
- ghc-tags.cabal +6/−7
- src/GhcTags/Config/Project.hs +9/−2
- src/GhcTags/Ghc.hs +57/−39
- src/GhcTags/GhcCompat.hs +13/−26
- src/GhcTags/Tag.hs +3/−3
- src/Main.hs +17/−16
CHANGELOG.md view
@@ -1,3 +1,9 @@+# ghc-tags-1.4 (2022-02-28)+* Add support for GHC 9.2.+* Require aeson >= 2.0.+* Enable `BlockArguments`, `ExplicitNamespaces`, `GADTSyntax`,+ `NumericUnderscores`, `PatternSynonyms` and `UnicodeSyntax` by default.+ # ghc-tags-1.3 (2021-05-23) * Properly escape ex mode search commands. * Fix parsing of generated ctags file.
README.md view
@@ -3,7 +3,9 @@ [](https://github.com/arybczak/ghc-tags/actions?query=branch%3Amaster) [](https://hackage.haskell.org/package/ghc-tags) -A command line tool that generates etags (Emacs) and ctags (Vim, VSCode with+A command line tool that generates etags+([Emacs](https://www.gnu.org/software/emacs)) and ctags+([Vim](https://www.vim.org), [VSCode](https://code.visualstudio.com) with [ctagsx](https://marketplace.visualstudio.com/items?itemName=jtanx.ctagsx) etc.) for efficient code navigation (jump to definition).
ghc-tags.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-version: 1.3+version: 1.4 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.10.4 || ==9.0.1+tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.1 source-repository head type: git@@ -28,13 +28,13 @@ executable ghc-tags ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-A4m - if !flag(ghc-lib) && impl(ghc == 9.0.*)+ if !flag(ghc-lib) && impl(ghc == 9.2.*) build-depends: ghc, ghc-boot else- build-depends: ghc-lib == 9.0.*+ build-depends: ghc-lib == 9.2.* - build-depends: base >=4.14 && <4.16- , aeson+ build-depends: base >=4.14 && <4.17+ , aeson >= 2.0.0.0 , async , attoparsec , bytestring@@ -49,7 +49,6 @@ , temporary , text , time- , unordered-containers , vector , yaml
src/GhcTags/Config/Project.hs view
@@ -10,9 +10,10 @@ import GHC.LanguageExtensions import GHC.Settings import System.Directory+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as K import qualified Data.ByteString.Char8 as BS import qualified Data.Map.Strict as Map-import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Yaml as Y import qualified Data.Yaml.Pretty as Y@@ -36,11 +37,17 @@ ] , pcLanguage = Haskell2010 , pcExtensions = [ BangPatterns+ , BlockArguments , ExplicitForAll+ , ExplicitNamespaces+ , GADTSyntax , LambdaCase , MultiWayIf+ , NumericUnderscores , OverloadedLabels+ , PatternSynonyms , TypeApplications+ , UnicodeSyntax ] , pcCppIncludes = [] , pcCppOptions = []@@ -101,7 +108,7 @@ instance FromJSON ProjectConfig where parseJSON (Object v) = do- checkUnknownKeys $ HM.keys v+ checkUnknownKeys . map K.toText $ K.keys v pcSourcePaths <- def pcSourcePaths <$> v .:! "source_paths" pcExcludePaths <- def pcExcludePaths <$> v .:! "exclude_paths" pcLanguage <- def pcLanguage <$> explicitParseFieldMaybe'
src/GhcTags/Ghc.hs view
@@ -11,17 +11,17 @@ import Data.Maybe import GHC.Data.Bag import GHC.Data.FastString-import GHC.Hs (HsModule(..))+import GHC.Hs (HsModule(..), NoExtField(..)) import GHC.Hs.Binds import GHC.Hs.Decls hiding (famResultKindSignature) import GHC.Hs.Expr import GHC.Hs.Extension import GHC.Hs.ImpExp import GHC.Hs.Type hiding (hsSigWcType)-import GHC.Types.Basic-import GHC.Types.FieldLabel+import GHC.Parser.Annotation import GHC.Types.Name (nameOccName, occNameFS) import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module.Name @@ -71,7 +71,7 @@ -- | Check if an identifier is exported. ---isExported :: Maybe [IE GhcPs] -> Located RdrName -> Bool+isExported :: Maybe [IE GhcPs] -> LocatedN RdrName -> Bool isExported Nothing _name = True isExported (Just ies) (L _ name) = any (\ie -> listToMaybe (ieNames ie) == Just name) ies@@ -79,8 +79,8 @@ -- | Check if a class member or a type constructors is exported. -- isMemberExported :: Maybe [IE GhcPs]- -> Located RdrName -- member name / constructor name- -> Located RdrName -- type class name / type constructor name+ -> LocatedN RdrName -- member name / constructor name+ -> LocatedN RdrName -- type class name / type constructor name -> Bool isMemberExported Nothing _memberName _className = True isMemberExported (Just ies) memberName className = any go ies@@ -93,31 +93,30 @@ go (IEThingAll _ (L _ n)) = ieWrappedName n == unLoc className - go (IEThingWith _ _ IEWildcard{} _ _) = True+ go (IEThingWith _ _ IEWildcard{} _) = True - go (IEThingWith _ (L _ n) NoIEWildcard ns lfls) =+ go (IEThingWith _ (L _ n) NoIEWildcard ns) = ieWrappedName n == unLoc className- && (isInWrappedNames || isInFieldLbls)+ && isInWrappedNames where -- the 'NameSpace' does not agree between things that are in the 'IE' -- list and passed member or type class names (constructor / type -- constructor names, respectively) isInWrappedNames = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . ieWrappedName . unLoc) ns- isInFieldLbls = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . flSelector. unLoc) lfls go _ = False -- | Create a 'GhcTag', effectively a smart constructor. ---mkGhcTag :: Located RdrName+mkGhcTag :: LocatedN RdrName -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier. -> GhcTagKind -- ^ tag's kind -> Bool -- ^ is term exported -> GhcTag-mkGhcTag (L gtSrcSpan rdrName) gtKind gtIsExported =+mkGhcTag (L SrcSpanAnn { locA = gtSrcSpan } rdrName) gtKind gtIsExported = case rdrName of Unqual occName -> GhcTag { gtTag = bytesFS (occNameFS occName)@@ -180,9 +179,9 @@ mies :: Maybe [IE GhcPs] mies = map unLoc . unLoc <$> hsmodExports - mkModNameTag :: Located ModuleName -> GhcTag- mkModNameTag (L gtSrcSpan modName) =- GhcTag { gtSrcSpan+ mkModNameTag :: LocatedA ModuleName -> GhcTag+ mkModNameTag (L l modName) =+ GhcTag { gtSrcSpan = locA l , gtTag = bytesFS $ moduleNameFS modName , gtKind = GtkModule , gtIsExported = True@@ -203,7 +202,7 @@ -- ^ declaration's location; it is useful when the term does not -- contain useful inforamtion (e.g. code generated from template -- haskell splices).- -> Located RdrName+ -> LocatedN RdrName -- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level -- identifier. -> GhcTagKind@@ -214,8 +213,8 @@ mkGhcTagForMember :: SrcSpan -- ^ declartion's 'SrcSpan'- -> Located RdrName -- member name- -> Located RdrName -- class name+ -> LocatedN RdrName -- member name+ -> LocatedN RdrName -- class name -> GhcTagKind -> GhcTag mkGhcTagForMember decLoc memberName className kind =@@ -225,7 +224,7 @@ -- Main routine which traverse all top level declarations. -- go :: LHsDecl GhcPs -> [GhcTag] -> [GhcTag]- go (L decLoc hsDecl) tags = case hsDecl of+ go (L SrcSpanAnn { locA = decLoc } hsDecl) tags = case hsDecl of -- type or class declaration TyClD _ tyClDecl ->@@ -271,8 +270,8 @@ -- associated type defaults (data type families, type families -- (open or closed) ++ foldr- (\(L _ decl@(TyFamInstDecl (HsIB { hsib_body = tyFamDeflEqn }))) tags' ->- case tyFamDeflEqn of+ (\(L _ decl@(TyFamInstDecl { tfid_eqn })) tags' ->+ case tfid_eqn of FamEqn { feqn_rhs = L _ hsType } -> case hsTypeTagName hsType of -- TODO: add a `default` field@@ -296,8 +295,8 @@ , cid_binds, cid_sigs } -> case cid_poly_ty of -- TODO: @hsbib_body :: LHsType GhcPs@- HsIB { hsib_body } ->- case mkLHsTypeTag decLoc hsib_body of+ L _ HsSig { sig_body } ->+ case mkLHsTypeTag decLoc sig_body of Nothing -> tags' Just tag -> tag : tags' where@@ -368,23 +367,23 @@ -- generate tags of all constructors of a type -- mkConsTags :: SrcSpan- -> Located RdrName+ -> LocatedN RdrName -- name of the type -> ConDecl GhcPs -- constructor declaration -> [GhcTag] - mkConsTags decLoc tyName con@ConDeclGADT { con_names, con_args } =+ mkConsTags decLoc tyName con@ConDeclGADT { con_names, con_g_args } = (\n -> mkGhcTagForMember decLoc n tyName (GtkGADTConstructor con)) `map` con_names- ++ mkHsConDeclDetails decLoc tyName con_args+ ++ mkHsConDeclGADTDetails decLoc tyName con_g_args mkConsTags decLoc tyName con@ConDeclH98 { con_name, con_args } = mkGhcTagForMember decLoc con_name tyName (GtkDataConstructor con)- : mkHsConDeclDetails decLoc tyName con_args+ : mkHsConDeclH98Details decLoc tyName con_args - mkHsLocalBindsTags :: SrcSpan -> HsLocalBindsLR GhcPs GhcPs -> [GhcTag]+ mkHsLocalBindsTags :: SrcSpan -> HsLocalBinds GhcPs -> [GhcTag] mkHsLocalBindsTags decLoc (HsValBinds _ (ValBinds _ hsBindsLR sigs)) = -- where clause bindings concatMap (mkHsBindLRTags decLoc . unLoc) (bagToList hsBindsLR)@@ -392,8 +391,12 @@ mkHsLocalBindsTags _ _ = [] - mkHsConDeclDetails :: SrcSpan -> Located RdrName -> HsConDeclDetails GhcPs -> [GhcTag]- mkHsConDeclDetails decLoc tyName (RecCon (L _ fields)) =+ mkHsConDeclGADTDetails+ :: SrcSpan+ -> LocatedN RdrName+ -> HsConDeclGADTDetails GhcPs+ -> [GhcTag]+ mkHsConDeclGADTDetails decLoc tyName (RecConGADT (L _ fields)) = foldr f [] fields where f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag]@@ -402,9 +405,23 @@ g :: LFieldOcc GhcPs -> GhcTag g (L _ FieldOcc { rdrNameFieldOcc }) = mkGhcTagForMember decLoc rdrNameFieldOcc tyName GtkRecordField+ mkHsConDeclGADTDetails _ _ _ = [] - mkHsConDeclDetails _ _ _ = []+ mkHsConDeclH98Details+ :: SrcSpan+ -> LocatedN RdrName+ -> HsConDeclH98Details GhcPs+ -> [GhcTag]+ mkHsConDeclH98Details decLoc tyName (RecCon (L _ fields)) =+ foldr f [] fields+ where+ f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag]+ f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names + g :: LFieldOcc GhcPs -> GhcTag+ g (L _ FieldOcc { rdrNameFieldOcc }) =+ mkGhcTagForMember decLoc rdrNameFieldOcc tyName GtkRecordField+ mkHsConDeclH98Details _ _ _ = [] mkHsBindLRTags :: SrcSpan -- ^ declaration's 'SrcSpan'@@ -412,7 +429,7 @@ -> [GhcTag] mkHsBindLRTags decLoc hsBind = case hsBind of FunBind { fun_id, fun_matches } ->- let binds = map (unLoc . grhssLocalBinds . m_grhss . unLoc)+ let binds = map (grhssLocalBinds . m_grhss . unLoc) . unLoc . mg_alts $ fun_matches@@ -426,14 +443,16 @@ -- ``` PatBind {} -> [] - VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag' decLoc (L srcSpan var_id) GtkTerm]+ -- According to the GHC documentation VarBinds are introduced by the+ -- type checker, so ghc-tags will never encounter them.+ VarBind {} -> [] -- abstraction binding is only used after translation AbsBinds {} -> [] PatSynBind _ PSB { psb_id } -> [mkGhcTag' decLoc psb_id GtkPatternSynonym] - mkClsMemberTags :: SrcSpan -> Located RdrName -> Sig GhcPs -> [GhcTag]+ mkClsMemberTags :: SrcSpan -> LocatedN RdrName -> Sig GhcPs -> [GhcTag] mkClsMemberTags decLoc clsName (TypeSig _ lhs hsSigWcType) = (\n -> mkGhcTagForMember decLoc n clsName (GtkTypeSignature hsSigWcType)) `map` lhs mkClsMemberTags decLoc clsName (PatSynSig _ lhs hsSigWcType) =@@ -477,7 +496,7 @@ mkFamilyDeclTags :: SrcSpan -> FamilyDecl GhcPs -- ^ declaration's 'SrcSpan'- -> Maybe (Located RdrName)+ -> Maybe (LocatedN RdrName) -- if this type family is associate, pass the name of the -- associated class -> Maybe GhcTag@@ -508,7 +527,7 @@ <$> hsTypeTagName hsType - hsTypeTagName :: HsType GhcPs -> Maybe (Located RdrName)+ hsTypeTagName :: HsType GhcPs -> Maybe (LocatedN RdrName) hsTypeTagName hsType = case hsType of HsForAllTy {hst_body} -> hsTypeTagName (unLoc hst_body)@@ -529,8 +548,7 @@ mkDataFamInstDeclTag :: SrcSpan -> DataFamInstDecl GhcPs -> [GhcTag] mkDataFamInstDeclTag decLoc DataFamInstDecl { dfid_eqn } = case dfid_eqn of-- HsIB { hsib_body = FamEqn { feqn_tycon, feqn_rhs } } ->+ FamEqn { feqn_tycon, feqn_rhs } -> case feqn_rhs of HsDataDefn { dd_cons, dd_kindSig } -> mkGhcTag' decLoc feqn_tycon@@ -545,7 +563,7 @@ mkTyFamInstDeclTag decLoc decl@TyFamInstDecl { tfid_eqn } = case tfid_eqn of -- TODO: should we check @feqn_rhs :: LHsType GhcPs@ as well?- HsIB { hsib_body = FamEqn { feqn_tycon } } ->+ FamEqn { feqn_tycon } -> Just $ mkGhcTag' decLoc feqn_tycon (GtkTypeFamilyInstance decl) --
src/GhcTags/GhcCompat.hs view
@@ -7,6 +7,7 @@ import Data.IORef import GHC.Data.FastString import GHC.Data.StringBuffer+import GHC.Driver.Config import GHC.Driver.Main import GHC.Driver.Monad import GHC.Driver.Session@@ -16,7 +17,6 @@ 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@@ -26,7 +26,6 @@ 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 @@ -38,7 +37,7 @@ parseModule filename flags buffer = unP Parser.parseModule parseState where location = mkRealSrcLoc (mkFastString filename) 1 1- parseState = mkPState flags buffer location+ parseState = initParserState (initParserOpts flags) buffer location runGhc :: Ghc a -> IO a runGhc m = do@@ -62,23 +61,15 @@ -- 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+ refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo) 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+ { dynamicTooFailed = refDynamicTooFailed+ , nextWrapperNum = wrapperNum+ , rtldInfo = refRtldInfo+ , rtccInfo = refRtccInfo } -- | Stripped version of 'GHC.Settings.IO.initSettings' that ignores the@@ -111,12 +102,12 @@ -- 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+ getRawFilePathSetting 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+ getRawBooleanSetting settingsFile mySettings key myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC, -- so we look in TopDir/../mingw/bin,@@ -252,7 +243,6 @@ -- Lots of uninitialized fields here. , sPlatformMisc = PlatformMisc {}- , sPlatformConstants = PlatformConstants { pc_DYNAMIC_BY_DEFAULT = False } , sRawSettings = settingsList }@@ -264,18 +254,15 @@ compatGetTargetPlatform settingsFile mySettings = do let readSetting :: (Show a, Read a) => String -> Either String a- readSetting = readSetting0 settingsFile mySettings+ readSetting = readRawSetting settingsFile mySettings - targetArch <- readSetting "target arch"- targetOS <- readSetting "target os"+ targetArchOS <- getTargetArchOS settingsFile mySettings targetWordSize <- readSetting "target word size" pure $ Platform- { platformMini = PlatformMini- { platformMini_arch = targetArch- , platformMini_os = targetOS- }+ { platformArchOS = targetArchOS , platformWordSize = targetWordSize+ , platform_constants = Nothing -- below is irrelevant , platformByteOrder = LittleEndian , platformUnregisterised = True
src/GhcTags/Tag.hs view
@@ -37,7 +37,7 @@ import qualified Data.Text.Encoding as Text -- GHC imports-import GHC.Driver.Session (DynFlags)+import GHC.Driver.Session (DynFlags, initSDocContext) import GHC.Data.FastString (bytesFS) import GHC.Types.SrcLoc@@ -447,8 +447,8 @@ Text.intercalate " " -- remove all line breaks, tabs and multiple spaces . Text.words . Text.pack- $ Out.renderWithStyle- (Out.initSDocContext+ $ Out.renderWithContext+ (initSDocContext dynFlags (Out.setStyleColoured False $ Out.mkErrStyle Out.neverQualify))
src/Main.hs view
@@ -13,13 +13,17 @@ import Data.Maybe (mapMaybe) import Data.Time import Data.Time.Format.ISO8601+import GHC (GhcException, setSessionDynFlags) import GHC.Conc (getNumProcessors) import GHC.Data.Bag import GHC.Data.StringBuffer+import GHC.Driver.Env.Types import GHC.Driver.Monad+import GHC.Driver.Pipeline+import GHC.Driver.Ppr import GHC.Driver.Session-import GHC.Driver.Types (HscEnv(..)) import GHC.Hs+import GHC.Parser.Errors.Ppr import GHC.Parser.Lexer import GHC.Types.SrcLoc import GHC.Utils.Error@@ -39,9 +43,6 @@ 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.Utils.Outputable as Out import GhcTags import GhcTags.Config.Args@@ -102,7 +103,7 @@ -- Extract tags from a given file and update the TagMap. worker :: IO () worker = runGhc $ do- void $ GHC.setSessionDynFlags . adjustDynFlags pc =<< getSessionDynFlags+ void $ setSessionDynFlags . adjustDynFlags pc =<< getSessionDynFlags env <- getSession liftIO . fix $ \loop -> atomically (readTBQueue $ wdQueue wd) >>= \case Nothing -> pure ()@@ -110,7 +111,7 @@ where processFile :: HscEnv -> FilePath -> HsFileType -> UTCTime -> IO () processFile env rawFile hsType mtime = withHsFile rawFile hsType $ \hsFile -> do- handle showErr $ DP.preprocess env hsFile Nothing Nothing >>= \case+ handle showErr $ preprocess env hsFile Nothing Nothing >>= \case Left errs -> report (hsc_dflags env) errs Right (flags, file) -> do --when (file /= rawFile) $ do@@ -118,13 +119,13 @@ buffer <- hGetStringBuffer file case parseModule file flags buffer of PFailed pstate -> do- let (wrns, errs) = getMessages pstate flags- report flags wrns- report flags errs+ let (wrns, errs) = getMessages pstate+ report flags (pprWarning <$> wrns)+ report flags (pprError <$> errs) POk pstate hsModule -> do- let (wrns, errs) = getMessages pstate flags- report flags wrns- report flags errs+ let (wrns, errs) = getMessages pstate+ report flags (pprWarning <$> wrns)+ report flags (pprError <$> errs) when (isEmptyBag errs) $ do modifyMVar_ (wdTags wd) $ \tags -> do pure $! updateTagsWith flags hsModule tags@@ -135,10 +136,10 @@ showErr :: GHC.GhcException -> IO () showErr = putStrLn . show - report :: DynFlags -> Bag ErrMsg -> IO ()+ report :: DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> IO () report flags msgs =- sequence_ [ putStrLn $ Out.showSDoc flags msg- | msg <- pprErrMsgBagWithLoc msgs+ sequence_ [ putStrLn $ showSDoc flags msg+ | msg <- pprMsgEnvelopeBagWithLoc msgs ] -- Alex and Hsc files need to be preprocessed before going into GHC.@@ -269,7 +270,7 @@ case res of Right (Right (headers, tags)) -> -- full evaluation decreases performance variation- deepseq headers . deepseq tags $ pure DirtyTags+ deepseq headers `seq` deepseq tags `seq` pure DirtyTags { dtKind = tt , dtHeaders = headers , dtTags = Map.map (Updated False) tags