ghc-tags 1.5 → 1.6
raw patch · 7 files changed
+99/−78 lines, 7 filesdep ~asyncdep ~basedep ~ghc-lib
Dependency ranges changed: async, base, ghc-lib
Files
- CHANGELOG.md +8/−0
- ghc-tags.cabal +5/−5
- src/GhcTags/Config/Project.hs +4/−0
- src/GhcTags/Ghc.hs +16/−21
- src/GhcTags/GhcCompat.hs +30/−30
- src/GhcTags/Tag.hs +3/−1
- src/Main.hs +33/−21
CHANGELOG.md view
@@ -1,3 +1,11 @@+# ghc-tags-1.6 (2023-01-30)+* Handle definitions of class methods properly.+* Enable `ImportQualifiedPost`, `MagicHash`, `QuasiQuotes` and+ `TemplateHaskellQuotes` by default.+* Allow parsing files more than once with different configurations.+* Add support for GHC 9.4 and drop support for GHC 8.10.+* Handle record pattern synonyms properly.+ # ghc-tags-1.5 (2022-05-15) * Handle errors more gracefully. * Enable `CApiFFI` by default.
ghc-tags.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-version: 1.5+version: 1.6 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.7 || ==9.0.2 || ==9.2.2+tested-with: GHC ==9.0.2 || ==9.2.5 || ==9.4.4 source-repository head type: git@@ -28,12 +28,12 @@ executable ghc-tags ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-A4m - if !flag(ghc-lib) && impl(ghc == 9.2.*)+ if !flag(ghc-lib) && impl(ghc == 9.4.*) build-depends: ghc, ghc-boot else- build-depends: ghc-lib == 9.2.*+ build-depends: ghc-lib == 9.4.* - build-depends: base >=4.14 && <4.17+ build-depends: base >=4.15 && <4.18 , aeson >= 2.0.0.0 , async , attoparsec
src/GhcTags/Config/Project.hs view
@@ -42,11 +42,15 @@ , ExplicitForAll , ExplicitNamespaces , GADTSyntax+ , ImportQualifiedPost , LambdaCase+ , MagicHash , MultiWayIf , NumericUnderscores , OverloadedLabels , PatternSynonyms+ , QuasiQuotes+ , TemplateHaskellQuotes , TypeApplications , UnicodeSyntax ]
src/GhcTags/Ghc.hs view
@@ -44,7 +44,7 @@ | GtkTypeKindSignature (LHsSigType GhcPs) | GtkPatternSynonym | GtkTypeClass- | GtkTypeClassMember (HsType GhcPs)+ | GtkTypeClassMember (HsWildCardBndrs GhcPs (LHsSigType GhcPs)) | GtkTypeClassInstance (HsType GhcPs) | GtkTypeFamily (Maybe ([HsTyVarBndr () GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs))) | GtkTypeFamilyInstance (TyFamInstDecl GhcPs)@@ -396,15 +396,15 @@ -> LocatedN RdrName -> HsConDeclGADTDetails GhcPs -> [GhcTag]- mkHsConDeclGADTDetails decLoc tyName (RecConGADT (L _ fields)) =+ mkHsConDeclGADTDetails decLoc tyName (RecConGADT (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+ g (L _ FieldOcc { foLabel }) =+ mkGhcTagForMember decLoc foLabel tyName GtkRecordField mkHsConDeclGADTDetails _ _ _ = [] mkHsConDeclH98Details@@ -419,8 +419,8 @@ 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+ g (L _ FieldOcc { foLabel }) =+ mkGhcTagForMember decLoc foLabel tyName GtkRecordField mkHsConDeclH98Details _ _ _ = [] mkHsBindLRTags :: SrcSpan@@ -447,24 +447,19 @@ -- 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]+ PatSynBind _ PSB { psb_id, psb_args } ->+ mkGhcTag' decLoc psb_id GtkPatternSynonym : case psb_args of+ RecCon fields ->+ let fldLabel = foLabel . recordPatSynField+ in map (\fld -> mkGhcTag' decLoc (fldLabel fld) GtkRecordField) fields+ _ -> [] 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) =- (\n -> mkGhcTagForMember decLoc n clsName $- GtkTypeSignature HsWC { hswc_ext = NoExtField- , hswc_body = hsSigWcType- }) `map` lhs mkClsMemberTags decLoc clsName (ClassOpSig _ _ lhs hsSigWcType) = (\n -> mkGhcTagForMember decLoc n clsName $- GtkTypeSignature HsWC { hswc_ext = NoExtField- , hswc_body = hsSigWcType- }) `map` lhs+ GtkTypeClassMember HsWC { hswc_ext = NoExtField+ , hswc_body = hsSigWcType+ }) `map` lhs mkClsMemberTags _ _ _ = [] @@ -537,7 +532,7 @@ HsTyVar _ _ a -> Just $ a HsAppTy _ a _ -> hsTypeTagName (unLoc a)- HsOpTy _ _ a _ -> Just $ a+ HsOpTy _ _ _ a _ -> Just $ a HsKindSig _ a _ -> hsTypeTagName (unLoc a) _ -> Nothing
src/GhcTags/GhcCompat.hs view
@@ -7,7 +7,7 @@ import Data.IORef import GHC.Data.FastString import GHC.Data.StringBuffer-import GHC.Driver.Config+import GHC.Driver.Config.Parser import GHC.Driver.Main import GHC.Driver.Monad import GHC.Driver.Session@@ -21,8 +21,8 @@ import GHC.SysTools import GHC.SysTools.BaseDir import GHC.Types.SrcLoc-import GHC.Unit.Module.Env import GHC.Utils.Fingerprint+import GHC.Utils.TmpFs import System.Directory import System.FilePath import qualified Data.Map.Strict as Map@@ -56,32 +56,19 @@ -- 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- refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo) refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing- wrapperNum <- newIORef emptyModuleEnv+ tmpdir <- liftIO getTemporaryDirectory pure dflags- { dynamicTooFailed = refDynamicTooFailed- , nextWrapperNum = wrapperNum- , rtldInfo = refRtldInfo- , rtccInfo = refRtccInfo+ { rtldInfo = refRtldInfo+ , rtccInfo = refRtccInfo+ , tmpDir = TempDir tmpdir } -- | 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@@ -101,13 +88,27 @@ -- 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 getBooleanSetting :: String -> IO Bool+ getBooleanSetting key = either error pure $+ getRawBooleanSetting settingsFile mySettings key++ -- On Windows, by mingw is often distributed with GHC,+ -- so we look in TopDir/../mingw/bin,+ -- as well as TopDir/../../mingw/bin for hadrian.+ -- But we might be disabled, in which we we don't do that.+ -- useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain"+ useInplaceMinGW <- pure True -- compatibility with GHC < 9.4+ -- see Note [topdir: How GHC finds its files]+ -- NB: top_dir is assumed to be in standard Unix+ -- format, '/' separated+ mtool_dir <- findToolDir useInplaceMinGW top_dir+ -- see Note [tooldir: How GHC finds mingw on Windows]+ let getSetting key = either error pure $ 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 $- getRawBooleanSetting settingsFile mySettings key+ getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key+ myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC, -- so we look in TopDir/../mingw/bin,@@ -150,10 +151,6 @@ 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"@@ -172,6 +169,9 @@ 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"+ let ld_r+ | null ld_r_prog = Nothing+ | otherwise = Just (ld_r_prog, map Option $ words ld_r_args) -- We just assume on command line lc_prog <- getSetting "LLVM llc command"@@ -187,8 +187,7 @@ } , sFileSettings = FileSettings- { fileSettings_tmpDir = normalise tmpdir- , fileSettings_ghcUsagePath = ghc_usage_msg_path+ { fileSettings_ghcUsagePath = ghc_usage_msg_path , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir@@ -208,7 +207,7 @@ , 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_lm = ld_r , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) , toolSettings_pgm_T = touch_path , toolSettings_pgm_windres = windres_path@@ -272,4 +271,5 @@ , platformIsCrossCompiling = False , platformLeadingUnderscore = False , platformTablesNextToCode = False+ , platformHasLibm = False }
src/GhcTags/Tag.hs view
@@ -193,6 +193,7 @@ deriving instance Show (TagDefinition tt) deriving instance Eq (TagDefinition tt)+deriving instance Ord (TagDefinition tt) -- | Unit of data associated with a tag. Vim natively supports `file:` and -- `kind:` tags but it can display any other tags too.@@ -227,6 +228,7 @@ deriving instance Show (TagFields tt) deriving instance Eq (TagFields tt)+deriving instance Ord (TagFields tt) instance Semigroup (TagFields tt) where NoTagFields <> NoTagFields = NoTagFields (TagFields a) <> (TagFields b) = TagFields (a ++ b)@@ -255,7 +257,7 @@ , tagFields :: TagFields tt -- ^ ctags specific field }- deriving (Show, Eq)+ deriving (Show, Eq, Ord) instance NFData (Tag tt) where rnf Tag{..} = rnf tagName
src/Main.hs view
@@ -23,8 +23,8 @@ import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Hs-import GHC.Parser.Errors.Ppr import GHC.Parser.Lexer+import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Error import System.Directory@@ -39,6 +39,7 @@ 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@@ -85,8 +86,13 @@ time <- getModificationTime path updateTags <- withMVar (wdTimes wd) $ \times -> pure $ case TagFileName (T.pack path) `Map.lookup` times of- Just (Updated _ oldTime) -> oldTime < time- Nothing -> True+ -- If the file was already updated, it means it's eligible for+ -- the update with regard to its mtime, but it was already+ -- processed. In such case we let it through in order to+ -- support the case of parsing the same file multiple times+ -- with different CPP options.+ Just (Updated updated oldTime) -> updated || oldTime < time+ Nothing -> True when updateTags $ do atomically . writeTBQueue (wdQueue wd) $ Just (path, hsType, time) where@@ -118,21 +124,21 @@ processFile :: HscEnv -> FilePath -> HsFileType -> UTCTime -> IO () processFile env rawFile hsType mtime = withHsFile rawFile hsType $ \hsFile -> do handle showErr $ preprocess env hsFile Nothing Nothing >>= \case- Left errs -> report (hsc_dflags env) errs+ Left errs -> report (hsc_dflags env) (getMessages errs) Right (flags, file) -> do --when (file /= rawFile) $ do -- putStrLn $ "Processing " ++ file ++ " (" ++ rawFile ++ ")" buffer <- hGetStringBuffer file case parseModule file flags buffer of PFailed pstate -> do- let (wrns, errs) = getMessages pstate- report flags (pprWarning <$> wrns)- report flags (pprError <$> errs)+ let (wrns, errs) = getPsMessages pstate+ report flags (getMessages wrns)+ report flags (getMessages errs) POk pstate hsModule -> do- let (wrns, errs) = getMessages pstate- report flags (pprWarning <$> wrns)- report flags (pprError <$> errs)- when (isEmptyBag errs) $ do+ let (wrns, errs) = getPsMessages pstate+ report flags (getMessages wrns)+ report flags (getMessages errs)+ when (isEmptyBag $ getMessages errs) $ do modifyMVar_ (wdTags wd) $ \tags -> do pure $! updateTagsWith flags hsModule tags modifyMVar_ (wdTimes wd) $ \times -> do@@ -142,7 +148,7 @@ showErr :: GHC.GhcException -> IO () showErr = putStrLn . show - report :: DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> IO ()+ report :: Diagnostic e => DynFlags -> Bag (MsgEnvelope e) -> IO () report flags msgs = sequence_ [ putStrLn $ showSDoc flags msg | msg <- pprMsgEnvelopeBagWithLoc msgs@@ -259,7 +265,7 @@ data DirtyTags = forall tt. DirtyTags { dtKind :: SingTagType tt , dtHeaders :: [CTag.Header]- , dtTags :: Map.Map TagFileName (Updated [Tag tt])+ , dtTags :: Map.Map TagFileName (Updated (Set.Set (Tag tt))) } data Tags = forall tt. Tags@@ -278,8 +284,7 @@ -- full evaluation decreases performance variation deepseq headers `seq` deepseq tags `seq` pure DirtyTags { dtKind = tt- , dtHeaders = headers- , dtTags = Map.map (Updated False) tags+ , dtHeaders = headers , dtTags = Map.map (Updated False . Set.fromList) tags } -- reading failed Left err -> do@@ -304,16 +309,23 @@ updateTagsWith :: DynFlags -> Located HsModule -> DirtyTags -> DirtyTags updateTagsWith dflags hsModule DirtyTags{..} =- DirtyTags { dtTags = fileTags `Map.union` dtTags+ DirtyTags { dtTags = Map.unionWith mergeTags fileTags dtTags , .. } where+ mergeTags (Updated newUpdated newTags) (Updated oldUpdated oldTags) =+ -- If the file was already updated, we merge tags. This supports the case+ -- of parsing the same file multiple times with different CPP options.+ if oldUpdated+ then Updated newUpdated $!! newTags `Set.union` oldTags+ else Updated newUpdated $!! newTags+ fileTags =- let tags = Map.fromListWith (++)- . map (second (:[]))+ let tags = Map.fromListWith Set.union+ . map (second Set.singleton) . mapMaybe (ghcTagToTag dtKind dflags) $ getGhcTags hsModule- in Map.map (Updated True) $!! tags+ in Map.map (Updated True) tags cleanupTags :: Args -> DirtyTags -> IO Tags cleanupTags args DirtyTags{..} = do@@ -324,13 +336,13 @@ -- here. exists <- doesFileExist path if | exists && updated -> do- let cleanedTags = ignoreSimilarClose $ sortBy compareNAK tags+ let cleanedTags = ignoreSimilarClose . sortBy compareNAK $ Set.toList tags case dtKind of SingCTag -> if aExModeSearch args then addExCommands file cleanedTags else pure $ Just cleanedTags SingETag -> addFileOffsets file cleanedTags- | exists && not updated -> pure $ Just tags+ | exists && not updated -> pure . Just $ Set.toList tags | otherwise -> pure Nothing newTags `deepseq` pure Tags { tKind = dtKind , tHeaders = dtHeaders