diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/ghc-tags.cabal b/ghc-tags.cabal --- a/ghc-tags.cabal +++ b/ghc-tags.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags -version: 1.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 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 @@ -42,11 +42,15 @@ , ExplicitForAll , ExplicitNamespaces , GADTSyntax + , ImportQualifiedPost , LambdaCase + , MagicHash , MultiWayIf , NumericUnderscores , OverloadedLabels , PatternSynonyms + , QuasiQuotes + , TemplateHaskellQuotes , TypeApplications , UnicodeSyntax ] diff --git a/src/GhcTags/Ghc.hs b/src/GhcTags/Ghc.hs --- a/src/GhcTags/Ghc.hs +++ b/src/GhcTags/Ghc.hs @@ -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 diff --git a/src/GhcTags/GhcCompat.hs b/src/GhcTags/GhcCompat.hs --- a/src/GhcTags/GhcCompat.hs +++ b/src/GhcTags/GhcCompat.hs @@ -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 } diff --git a/src/GhcTags/Tag.hs b/src/GhcTags/Tag.hs --- a/src/GhcTags/Tag.hs +++ b/src/GhcTags/Tag.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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