diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -64,3 +64,8 @@ * fix emacs support: ghc-tags-plugin can now correctly display multiple tags (e.g. instance declarations). Thanks to @nfrisby for finding out how to do that. + +## 0.4.0.0 -- 2022-01-09 + +* `ghc-tags-plugin` is not compatible with `ghc-9.2` +* `--stream` option, only effective for `ctags`; When enabled, `ghc-tags-plugin` streams existing tags when adding the tags found in a new module. Without this option the tags file is read at once into memory. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,9 +3,7 @@ ![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-8D82AC.svg) ![MPL-2.0 License](http://img.shields.io/badge/license-MPL20-brightgreen.svg) -[![](https://github.com/coot/ghc-tags-plugin/workflows/Linux%20GHC-8.6.5/badge.svg)](https://github.com/coot/ghc-tags-plugin/actions) -[![](https://github.com/coot/ghc-tags-plugin/workflows/Linux%20GHC-8.8.3/badge.svg)](https://github.com/coot/ghc-tags-plugin/actions) -[![](https://github.com/coot/ghc-tags-plugin/workflows/Windows%20GHC-8.6.5/badge.svg)](https://github.com/coot/ghc-tags-plugin/actions) +[![Haskell CI](https://github.com/coot/ghc-tags-plugin/actions/workflows/ci.yml/badge.svg)](https://github.com/coot/ghc-tags-plugin/actions/workflows/ci.yml) [![](https://matrix.hackage.haskell.org/api/v2/packages/ghc-tags-plugin/badge)](https://matrix.hackage.haskell.org/#/package/ghc-tags-plugin) A [Ghc Compiler Plugin](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/extending_ghc.html#compiler-plugins) @@ -23,13 +21,15 @@ ---------------- ``` -Usage: [-e|--etags] [file_path] +Usage: [-e|--etags] [--stream] [--debug] [file_path] write tags from ghc abstract syntax tree Available options: -e,--etags produce emacs etags file + --stream stream existing tags (ctags only) file_path tags file: default tags or TAGS (when --etags is specified) + --debug debugging output ``` It can be an absolute path or relative (to the `*.cabal` package file rather diff --git a/app/check.hs b/app/check.hs --- a/app/check.hs +++ b/app/check.hs @@ -17,7 +17,7 @@ main :: IO () main = do file :_ <- getArgs - withFileLock (lockFile file) ExclusiveLock $ \_h -> do + withFileLock False (lockFile file) ExclusiveLock $ \_h -> do numOfLines <- length . BSC.lines <$> BS.readFile file putStrLn (show numOfLines) where diff --git a/ghc-tags-plugin.cabal b/ghc-tags-plugin.cabal --- a/ghc-tags-plugin.cabal +++ b/ghc-tags-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-plugin -version: 0.3.0.0 +version: 0.4.0.0 synopsis: A compiler plugin which generates tags file from GHC parsed syntax tree. description: A [GHC compiler plugin](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/extending_ghc.html?highlight=compiler%20plugin#compiler-plugins) @@ -18,7 +18,7 @@ README.md homepage: https://github.com/coot/ghc-tags-plugin#readme bug-reports: https://github.com/coot/ghc-tags-plugin/issues -tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.4 +tested-with: GHC==8.8.4, GHC==8.10.7, GHC==9.0.1, GHC==9.2.1 -- Don't build gtp-check command by default; it's a development tool. flag gtp-check @@ -37,14 +37,14 @@ other-modules: Plugin.GhcTags.CTag Paths_ghc_tags_plugin autogen-modules: Paths_ghc_tags_plugin - build-depends: base >=4.12.0.0 && <4.16, + build-depends: base >=4.12.0.0 && <4.17, bytestring >=0.10 && < 0.12, directory ^>=1.3, filepath ^>=1.4, filepath-bytestring ^>=1.4, ghc >=8.4 && <10, - lukko ^>=0.1, + lukko >=0.1, mtl ^>=2.2, optparse-applicative >=0.15.1 && < 0.17, @@ -60,6 +60,8 @@ ghc-options: -Wall -Wno-unticked-promoted-constructors -Wcompat + -- the following three warnings are enabled by -Wall in + -- ghc-9.2 -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields diff --git a/lib/Plugin/GhcTags.hs b/lib/Plugin/GhcTags.hs --- a/lib/Plugin/GhcTags.hs +++ b/lib/Plugin/GhcTags.hs @@ -26,9 +26,7 @@ #endif import Data.Functor.Identity (Identity (..)) import Data.List (sortBy) -#if __GLASGOW_HASKELL__ >= 810 import Data.Either (partitionEithers) -#endif import Data.Foldable (traverse_) import Data.Maybe (mapMaybe) import System.Directory @@ -37,13 +35,6 @@ import qualified System.FilePath.ByteString as FilePath import System.IO -#if !defined(mingw32_HOST_OS) -import Foreign.C.Types (CInt (..)) -import Foreign.C.Error (throwErrnoIfMinus1_) -import GHC.IO.FD (FD (..)) -import GHC.IO.Handle.FD (handleToFd) -#endif - import Options.Applicative.Types (ParserFailure (..)) import qualified Pipes as Pipes @@ -59,8 +50,25 @@ ( CommandLineOption , Plugin (..) ) -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 900 import qualified GHC.Driver.Plugins as GhcPlugins +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Driver.Env ( Hsc + , HscEnv (..) + ) +import GHC.Hs (HsParsedModule (..)) +import GHC.Unit.Module.ModSummary + (ModSummary (..)) +import GHC.Types.Meta ( MetaHook + , MetaRequest (..) + , MetaResult + , metaRequestAW + , metaRequestD + , metaRequestE + , metaRequestP + , metaRequestT + ) +#else import GHC.Driver.Types ( Hsc , HsParsedModule (..) , ModSummary (..) @@ -73,12 +81,14 @@ , metaRequestP , metaRequestT ) +#endif import GHC.Driver.Hooks (Hooks (..)) import GHC.Unit.Types (Module) import GHC.Unit.Module.Location (ModLocation (..)) import GHC.Tc.Types (TcM) import GHC.Tc.Gen.Splice (defaultRunMeta) import GHC.Types.SrcLoc (Located) +import qualified GHC.Types.SrcLoc as GHC (SrcSpan (..), getLoc, srcSpanFile) #else import qualified GhcPlugins import GhcPlugins ( Hsc @@ -98,11 +108,14 @@ , metaRequestT #endif ) +import qualified SrcLoc as GHC (SrcSpan (..), getLoc, srcSpanFile) #endif -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Driver.Session (DynFlags (hooks)) +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Driver.Session (DynFlags) +#elif __GLASGOW_HASKELL__ >= 900 +import GHC.Driver.Session (DynFlags (DynFlags, hooks)) #elif __GLASGOW_HASKELL__ >= 810 -import DynFlags (DynFlags (hooks)) +import DynFlags (DynFlags (DynFlags, hooks)) #else import DynFlags (DynFlags) #endif @@ -127,6 +140,13 @@ import qualified Outputable as Out import qualified PprColour #endif +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Data.FastString (bytesFS) +#elif __GLASGOW_HASKELL__ >= 810 +import FastString (bytesFS) +#else +import FastString (FastString (fs_bs)) +#endif import GhcTags.Ghc import GhcTags.Tag @@ -139,6 +159,11 @@ import qualified Plugin.GhcTags.CTag as CTag +#if __GLASGOW_HASKELL__ < 810 +bytesFS :: FastString -> ByteString +bytesFS = fs_bs +#endif + #if __GLASGOW_HASKELL__ >= 900 type GhcPsModule = HsModule #else @@ -176,7 +201,9 @@ plugin :: Plugin plugin = GhcPlugins.defaultPlugin { parsedResultAction = ghcTagsParserPlugin, -#if __GLASGOW_HASKELL__ >= 810 +#if __GLASGOW_HASKELL__ >= 902 + driverPlugin = ghcTagsDriverPlugin, +#elif __GLASGOW_HASKELL__ >= 810 dynflagsPlugin = ghcTagsDynflagsPlugin, #endif pluginRecompile = GhcPlugins.purePlugin @@ -208,40 +235,38 @@ } -> liftIO $ do - let sourceFile = case splitFileName tagsFile of - (dir, name) -> dir "." ++ name - lockFile = sourceFile ++ ".lock" - -- wrap 'IOException's handle (\ioerr -> do putDocLn dynFlags (messageDoc UnhandledException (Just ms_mod) (displayException ioerr)) throwIO (GhcTagsParserPluginIOException ioerr)) $ - flip finally (void $ try @IOException $ removeFile sourceFile) $ + + let lockFile = case splitFileName tagsFile of + (dir, name) -> dir "." ++ name ++ ".lock" in -- Take advisory exclusive lock (a BSD lock using `flock`) on the tags -- file. This is needed when `cabal` compiles in parallel. -- We take the lock on the copy, otherwise the lock would be removed when -- we move the file. - withFileLock lockFile ExclusiveLock $ \_ -> do + withFileLock debug lockFile ExclusiveLock $ \_ -> do mbInSize <- if debug then Just <$> getFileSize tagsFile `catch` \(_ :: IOException) -> pure 0 else pure Nothing - updateTags opts moduleSummary hpm_module sourceFile + updateTags opts moduleSummary hpm_module when debug $ do let Just inSize = mbInSize outSize <- getFileSize tagsFile when (inSize > outSize) - $ throwIO (userError $ concat - [ "tags file '" - , tagsFile - , "' size shrinked: " - , show inSize - , "→" - , show outSize - ]) + $ liftIO + $ putDocLn dynFlags + (messageDoc SizeWarning + (Just ms_mod) + (concat [ show inSize + , "→" + , show outSize + ])) Failure (ParserFailure f) -> liftIO $ @@ -262,6 +287,7 @@ | UnhandledException | OptionParserFailure | DebugMessage + | SizeWarning instance Show MessageType where @@ -270,159 +296,307 @@ show WriteException = "write error" show UnhandledException = "unhandled error" show OptionParserFailure = "plugin options parser error" + show SizeWarning = "tags file shrinked" show DebugMessage = "" + -- | Extract tags from a module and update tags file -- updateTags :: Options Identity -> ModSummary -> Located GhcPsModule - -> FilePath -> IO () -updateTags Options { etags, filePath = Identity tagsFile, debug } +updateTags Options { etags, stream, filePath = Identity tagsFile, debug } ModSummary {ms_mod, ms_location, ms_hspp_opts = dynFlags} - lmodule sourceFile = do - tagsFileExists <- doesFileExist tagsFile - when tagsFileExists - $ renameFile tagsFile sourceFile - withFile tagsFile WriteMode $ \writeHandle -> - withFile sourceFile ReadWriteMode $ \readHandle -> do - cwd <- BSC.pack <$> getCurrentDirectory - -- absolute directory path of the tags file; we need canonical path - -- (without ".." and ".") to make 'makeRelative' works. - tagsDir <- BSC.pack <$> canonicalizePath (fst $ splitFileName tagsFile) + lmodule = do + case (etags, stream) of + (False, True) -> updateCTags_stream + (False, False) -> updateCTags + (True, _) -> updateETags + where + updateCTags_stream, updateCTags, updateETags :: IO () - case (etags, ml_hs_file ms_location) of + -- + -- update ctags (streaming) + -- + -- Stream ctags from from the tags file and intersparse tags parsed from + -- the current module. The results are written to a destination file which + -- is then renamed to tags file. + updateCTags_stream = do + tagsFileExists <- doesFileExist tagsFile + let destFile = case splitFileName tagsFile of + (dir, name) -> dir "." ++ name - -- - -- ctags - -- - (False, Nothing) -> pure () - (False, Just sourcePath) -> do + mbInSize <- + if debug + then + if tagsFileExists + then Just <$> getFileSize tagsFile + `catch` \(_ :: IOException) -> pure 0 + else pure (Just 0) + else pure Nothing - let sourcePathBS = Text.encodeUtf8 (Text.pack sourcePath) - -- text parser - producer :: Pipes.Producer ByteString (SafeT IO) () - producer - | tagsFileExists = - void (Pipes.BS.fromHandle readHandle) - `Pipes.Safe.catchP` \(e :: IOException) -> - Pipes.lift $ Pipes.liftIO $ - -- don't re-throw; this would kill `ghc`, error - -- loudly and continue. - putDocLn dynFlags (messageDoc ReadException (Just ms_mod) (displayException e)) - | otherwise = pure () + -- when tagsFileExists + -- $ renameFile tagsFile destFile + withFile destFile WriteMode $ \writeHandle -> + withFile tagsFile ReadWriteMode $ \readHandle -> do + cwd <- BSC.pack <$> getCurrentDirectory + -- absolute directory path of the tags file; we need canonical path + -- (without ".." and ".") to make 'makeRelative' works. + tagsDir <- BSC.pack <$> canonicalizePath (fst $ splitFileName tagsFile) + case ml_hs_file ms_location of + Nothing -> pure () + Just sourcePath -> do + let sourcePathBS = Text.encodeUtf8 (Text.pack sourcePath) + -- path of the combiled module; it is relative to the cabal file, + -- not the project. + modulePath = + case GHC.getLoc lmodule of +#if __GLASGOW_HASKELL__ >= 900 + GHC.RealSrcSpan rss _ -> +#else + GHC.RealSrcSpan rss -> +#endif + bytesFS + . GHC.srcSpanFile + $ rss + GHC.UnhelpfulSpan {} -> + fixFilePath cwd tagsDir sourcePathBS + -- text parser + producer :: Pipes.Producer ByteString (SafeT IO) () + producer + | tagsFileExists = + void (Pipes.BS.fromHandle readHandle) + `Pipes.Safe.catchP` \(e :: IOException) -> + Pipes.lift $ Pipes.liftIO $ + -- don't re-throw; this would kill `ghc`, error + -- loudly and continue. + putDocLn dynFlags (messageDoc ReadException (Just ms_mod) (displayException e)) + | otherwise = pure () - -- tags pipe - pipe :: Pipes.Effect (StateT Int (StateT [CTag] (SafeT IO))) () - pipe = - Pipes.for - (Pipes.hoist Pipes.lift $ Pipes.hoist Pipes.lift (tagParser (either (const Nothing) Just <$> CTag.parseTagLine) producer) - `Pipes.Safe.catchP` \(e :: IOException) -> - Pipes.lift $ Pipes.liftIO $ - -- don't re-throw; this would kill `ghc`, error - -- loudly and continue. - putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException e) - ) - $ - -- merge tags - (\tag -> do - modify' succ - Pipes.hoist Pipes.lift $ - runCombineTagsPipe writeHandle - CTag.compareTags - CTag.formatTag - (fixFilePath cwd tagsDir sourcePathBS) - tag - `Pipes.Safe.catchP` \(e :: IOException) -> - Pipes.lift $ Pipes.liftIO $ - -- don't re-throw; this would kill `ghc`, error - -- loudly and continue. - putDocLn dynFlags $ messageDoc WriteException (Just ms_mod) (displayException e) - ) + -- tags pipe + pipe :: Pipes.Effect (StateT Int (StateT [CTag] (SafeT IO))) () + pipe = + Pipes.for + (Pipes.hoist Pipes.lift $ Pipes.hoist Pipes.lift (tagParser (either (const Nothing) Just <$> CTag.parseTagLine) producer) + `Pipes.Safe.catchP` \(e :: IOException) -> + Pipes.lift $ Pipes.liftIO $ + -- don't re-throw; this would kill `ghc`, error + -- loudly and continue. + putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException e) + ) + $ + -- merge tags + (\tag -> do + -- update tags counter + modify' succ + Pipes.hoist Pipes.lift $ + runCombineTagsPipe writeHandle + CTag.compareTags + CTag.formatTag + modulePath + tag + `Pipes.Safe.catchP` \(e :: IOException) -> + Pipes.lift $ Pipes.liftIO $ + -- don't re-throw; this would kill `ghc`, error + -- loudly and continue. + putDocLn dynFlags $ messageDoc WriteException (Just ms_mod) (displayException e) + ) - let tags :: [CTag] - tags = map (fixTagFilePath cwd tagsDir) - -- fix file names - . filterAdjacentTags - . sortBy compareTags -- sort - . mapMaybe (ghcTagToTag SingCTag dynFlags) - -- translate 'GhcTag' to 'Tag' - . getGhcTags -- generate 'GhcTag's - $ lmodule + let tags :: [CTag] + tags = map (fixTagFilePath cwd tagsDir) + -- fix file names + . filterAdjacentTags + . sortBy compareTags -- sort + . mapMaybe (ghcTagToTag SingCTag dynFlags) + -- translate 'GhcTag' to 'Tag' + . getGhcTags -- generate 'GhcTag's + $ lmodule - -- Write header - BSL.hPut writeHandle (BB.toLazyByteString (foldMap CTag.formatHeader CTag.headers)) - -- update tags file / run 'pipe' - (parsedTags, tags') <- Pipes.Safe.runSafeT $ runStateT (execStateT (Pipes.runEffect pipe) 0) tags - -- write the remaining tags' - traverse_ (BSL.hPut writeHandle . BB.toLazyByteString . CTag.formatTag) tags' + -- Write header + BSL.hPut writeHandle (BB.toLazyByteString (foldMap CTag.formatHeader CTag.headers)) + -- update tags file / run 'pipe' + (parsedTags, tags') <- Pipes.Safe.runSafeT $ runStateT (execStateT (Pipes.runEffect pipe) 0) tags + -- write the remaining tags' + traverse_ (BSL.hPut writeHandle . BB.toLazyByteString . CTag.formatTag) tags' - hFlush writeHandle - -- hDataSync is necessary, otherwise next read will not get all the - -- data, and the tags file will get truncated. Issue #37. - hDataSync writeHandle + hFlush writeHandle - when debug - $ printMessageDoc dynFlags DebugMessage (Just ms_mod) - (concat [ "parsed: " - , show parsedTags - , " found: " - , show (length tags) - , " left: " - , show (length tags') - ]) + when debug $ do + outSize <- getFileSize tagsFile + let Just inSize = mbInSize + printMessageDoc dynFlags DebugMessage (Just ms_mod) + (concat [ "path: " + , show modulePath + , " parsed: " + , show parsedTags + , " found: " + , show (length tags + length tags') + , " in-size: " + , show inSize + , " out-size: " + , show outSize + ]) + + destFileExists <- doesFileExist destFile + when destFileExists $ + renameFile destFile tagsFile - -- - -- etags - -- - (True, Nothing) -> pure () - (True, Just sourcePath) -> - try @IOException (BS.hGetContents readHandle) - >>= \case - Left err -> - putDocLn dynFlags $ messageDoc ReadException (Just ms_mod) (displayException err) - Right txt -> do - pres <- try @IOException $ ETag.parseTagsFile txt - case pres of - Left err -> - putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException err) + -- + -- update ctags (non streaming) + -- + updateCTags = do + tagsFileExists <- doesFileExist tagsFile - Right (Left err) -> - printMessageDoc dynFlags ParserException (Just ms_mod) err + mbInSize <- + if debug + then + if tagsFileExists + then Just <$> getFileSize tagsFile + `catch` \(_ :: IOException) -> pure 0 + else pure (Just 0) + else pure Nothing + !tagsContent <- if tagsFileExists + then BS.readFile tagsFile + else return mempty + withFile tagsFile WriteMode $ \writeHandle -> do + cwd <- BSC.pack <$> getCurrentDirectory + -- absolute directory path of the tags file; we need canonical path + -- (without ".." and ".") to make 'makeRelative' works. + tagsDir <- BSC.pack <$> canonicalizePath (fst $ splitFileName tagsFile) + case ml_hs_file ms_location of + Nothing -> pure () + Just sourcePath -> do + let sourcePathBS = Text.encodeUtf8 (Text.pack sourcePath) + -- path of the combiled module; it is relative to the cabal file, + -- not the project. + modulePath = + case GHC.getLoc lmodule of +#if __GLASGOW_HASKELL__ >= 900 + GHC.RealSrcSpan rss _ -> +#else + GHC.RealSrcSpan rss -> +#endif + bytesFS + . GHC.srcSpanFile + $ rss + GHC.UnhelpfulSpan {} -> + fixFilePath cwd tagsDir sourcePathBS - Right (Right tags) -> do - let sourcePathBS = Text.encodeUtf8 (Text.pack sourcePath) + pres <- try @IOException $ CTag.parseTagsFile tagsContent + case pres of + Left err -> + putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException err) - newTags :: [ETag] - newTags = - filterAdjacentTags - . sortBy ETag.compareTags - . map (fixTagFilePath cwd tagsDir) - . mapMaybe (ghcTagToTag SingETag dynFlags) - . getGhcTags - $ lmodule + Right (Left err) -> + printMessageDoc dynFlags ParserException (Just ms_mod) err - tags' :: [ETag] - tags' = combineTags - ETag.compareTags - (fixFilePath cwd tagsDir sourcePathBS) - newTags - (sortBy ETag.compareTags tags) + Right (Right !parsed) -> do + let (headers, !parsedTags) = partitionEithers parsed - when debug - $ printMessageDoc dynFlags DebugMessage (Just ms_mod) - (concat [ "parsed: " - , show (length tags) - , " found: " - , show (length newTags) - ]) + tags :: [CTag] + tags = map (fixTagFilePath cwd tagsDir) + -- fix file names + . filterAdjacentTags + . sortBy compareTags -- sort + . mapMaybe (ghcTagToTag SingCTag dynFlags) + -- translate 'GhcTag' to 'Tag' + . getGhcTags -- generate 'GhcTag's + $ lmodule - BB.hPutBuilder writeHandle (ETag.formatETagsFile tags') + combined :: [CTag] + combined = combineTags CTag.compareTags modulePath tags parsedTags + BB.hPutBuilder writeHandle + ( foldMap CTag.formatHeader headers + <> foldMap CTag.formatTag combined + ) + when debug $ do + outSize <- getFileSize tagsFile + let Just inSize = mbInSize + printMessageDoc dynFlags DebugMessage (Just ms_mod) + (concat [ "parsed: " + , show (length parsedTags) + , " found: " + , show (length tags) + , " in-size: " + , show inSize + , " out-size: " + , show outSize + ]) + + + -- + -- update etags file + -- + updateETags = do + tagsFileExists <- doesFileExist tagsFile + + mbInSize <- + if debug + then + if tagsFileExists + then Just <$> getFileSize tagsFile + `catch` \(_ :: IOException) -> pure 0 + else pure (Just 0) + else pure Nothing + !tagsContent <- if tagsFileExists + then BS.readFile tagsFile + else return mempty + withFile tagsFile WriteMode $ \writeHandle -> do + cwd <- BSC.pack <$> getCurrentDirectory + -- absolute directory path of the tags file; we need canonical path + -- (without ".." and ".") to make 'makeRelative' works. + tagsDir <- BSC.pack <$> canonicalizePath (fst $ splitFileName tagsFile) + + case ml_hs_file ms_location of + Nothing -> pure () + Just sourcePath -> do + pres <- try @IOException $ ETag.parseTagsFile tagsContent + case pres of + Left err -> + putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException err) + + Right (Left err) -> + printMessageDoc dynFlags ParserException (Just ms_mod) err + + Right (Right parsedTags) -> do + let sourcePathBS = Text.encodeUtf8 (Text.pack sourcePath) + + tags :: [ETag] + tags = filterAdjacentTags + . sortBy ETag.compareTags + . map (fixTagFilePath cwd tagsDir) + . mapMaybe (ghcTagToTag SingETag dynFlags) + . getGhcTags + $ lmodule + + combined :: [ETag] + combined = combineTags ETag.compareTags + (fixFilePath cwd tagsDir sourcePathBS) + tags + (sortBy ETag.compareTags tags) + + BB.hPutBuilder writeHandle (ETag.formatETagsFile combined) + + when debug $ do + outSize <- getFileSize tagsFile + let Just inSize = mbInSize + printMessageDoc dynFlags DebugMessage (Just ms_mod) + (concat [ "parsed: " + , show (length parsedTags) + , " found: " + , show (length tags) + , " in-size: " + , show inSize + , " out-size: " + , show outSize + ]) + + -- | Filter adjacent tags. -- filterAdjacentTags :: [Tag tk] -> [Tag tk] @@ -447,7 +621,7 @@ -> acc _ -> c : acc - + ) [] (zip3 tags' tags tags'') @@ -468,86 +642,90 @@ -- Tags for Template-Haskell splices -- +#if __GLASGOW_HASKELL__ >= 902 +ghcTagsDriverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv +ghcTagsDriverPlugin opts env@HscEnv{ hsc_hooks } = do + let hook = ghcTagsMetaHook opts (hsc_dflags env) + return env { hsc_hooks = hsc_hooks { runMetaHook = Just hook } } +#else +ghcTagsDynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags +ghcTagsDynflagsPlugin options dynFlags@DynFlags { hooks } = do + let hook = ghcTagsMetaHook options dynFlags + return dynFlags { hooks = hooks { runMetaHook = Just hook } } + +#endif + -- | DynFlags plugin which extract tags from TH splices. -- -ghcTagsDynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags -ghcTagsDynflagsPlugin options dynFlags = - pure dynFlags - { hooks = - (hooks dynFlags) - { runMetaHook = Just ghcTagsMetaHook } - } - where - ghcTagsMetaHook :: MetaHook TcM - ghcTagsMetaHook request expr = - case runOptionParser options of - Success Options { filePath = Identity tagsFile - , etags - } -> do - let sourceFile = case splitFileName tagsFile of - (dir, name) -> dir "." ++ name - lockFile = sourceFile ++ ".lock" +ghcTagsMetaHook :: [CommandLineOption] -> DynFlags -> MetaHook TcM +ghcTagsMetaHook options dynFlags request expr = + case runOptionParser options of + Success Options { filePath = Identity tagsFile + , etags + , debug + } -> do - withMetaD defaultRunMeta request expr $ \decls -> - liftIO $ - handle (\ioerr -> do - putDocLn dynFlags - (messageDoc UnhandledException Nothing - (displayException ioerr)) - throwIO (GhcTagsDynFlagsPluginIOException ioerr)) $ - withFileLock lockFile ExclusiveLock $ \_ -> do - cwd <- BSC.pack <$> getCurrentDirectory - tagsDir <- BSC.pack <$> canonicalizePath (fst $ splitFileName tagsFile) - tagsContent <- BSC.readFile tagsFile - if etags - then do - pr <- ETag.parseTagsFile tagsContent - case pr of - Left err -> - printMessageDoc dynFlags ParserException Nothing err + withMetaD defaultRunMeta request expr $ \decls -> + liftIO $ + handle (\ioerr -> do + putDocLn dynFlags + (messageDoc UnhandledException Nothing + (displayException ioerr)) + throwIO (GhcTagsDynFlagsPluginIOException ioerr)) $ + withFileLock debug tagsFile ExclusiveLock $ \_ -> do + cwd <- BSC.pack <$> getCurrentDirectory + tagsDir <- BSC.pack <$> canonicalizePath (fst $ splitFileName tagsFile) + tagsContent <- BSC.readFile tagsFile + if etags + then do + pr <- ETag.parseTagsFile tagsContent + case pr of + Left err -> + printMessageDoc dynFlags ParserException Nothing err - Right tags -> do - let tags' :: [ETag] - tags' = sortBy ETag.compareTags $ - tags - ++ - (fmap (fixTagFilePath cwd tagsDir) - . ghcTagToTag SingETag dynFlags) - `mapMaybe` - hsDeclsToGhcTags Nothing decls - BSL.writeFile tagsFile (BB.toLazyByteString $ ETag.formatTagsFile tags') - else do - pr <- fmap partitionEithers <$> CTag.parseTagsFile tagsContent - case pr of - Left err -> - printMessageDoc dynFlags ParserException Nothing err + Right tags -> do + let tags' :: [ETag] + tags' = sortBy ETag.compareTags $ + tags + ++ + (fmap (fixTagFilePath cwd tagsDir) + . ghcTagToTag SingETag dynFlags) + `mapMaybe` + hsDeclsToGhcTags Nothing decls + BSL.writeFile tagsFile (BB.toLazyByteString $ ETag.formatTagsFile tags') + else do + pr <- fmap partitionEithers <$> CTag.parseTagsFile tagsContent + case pr of + Left err -> + printMessageDoc dynFlags ParserException Nothing err - Right (headers, tags) -> do - let tags' :: [Either CTag.Header CTag] - tags' = Left `map` headers - ++ Right `map` - sortBy CTag.compareTags - ( tags - ++ - (fmap (fixTagFilePath cwd tagsDir) - . ghcTagToTag SingCTag dynFlags) - `mapMaybe` - hsDeclsToGhcTags Nothing decls - ) - BSL.writeFile tagsFile (BB.toLazyByteString $ CTag.formatTagsFile tags') + Right (headers, tags) -> do + let tags' :: [Either CTag.Header CTag] + tags' = Left `map` headers + ++ Right `map` + sortBy CTag.compareTags + ( tags + ++ + (fmap (fixTagFilePath cwd tagsDir) + . ghcTagToTag SingCTag dynFlags) + `mapMaybe` + hsDeclsToGhcTags Nothing decls + ) + BSL.writeFile tagsFile (BB.toLazyByteString $ CTag.formatTagsFile tags') - Failure (ParserFailure f) -> - withMetaD defaultRunMeta request expr $ \_ -> - liftIO $ - putDocLn dynFlags - (messageDoc - OptionParserFailure - Nothing - (show (case f "" of (h, _, _) -> h) - ++ " " ++ show options)) + Failure (ParserFailure f) -> + withMetaD defaultRunMeta request expr $ \_ -> + liftIO $ + putDocLn dynFlags + (messageDoc + OptionParserFailure + Nothing + (show (case f "" of (h, _, _) -> h) + ++ " " ++ show options)) - CompletionInvoked {} -> error "ghc-tags-plugin: impossible happend" + CompletionInvoked {} -> error "ghc-tags-plugin: impossible happend" + where -- run the hook and call call the callback with new declarations withMetaD :: MetaHook TcM -> MetaRequest -> LHsExpr GhcTc -> ([LHsDecl GhcPs] -> TcM a) @@ -633,6 +811,7 @@ WriteException -> Error UnhandledException -> Error OptionParserFailure -> Warning + SizeWarning -> Warning DebugMessage -> Debug messageColour = case severity of @@ -642,9 +821,17 @@ putDocLn :: DynFlags -> Out.SDoc -> IO () -putDocLn dynFlags sdoc = +#if __GLASGOW_HASKELL__ >= 902 +putDocLn _dynFlags sdoc = +#else +putDocLn dynFlags sdoc = +#endif putStrLn $ -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 902 + Out.renderWithContext + Out.defaultSDocContext { Out.sdocStyle = Out.mkErrStyle Out.neverQualify } + sdoc +#elif __GLASGOW_HASKELL__ >= 900 Out.renderWithStyle (Out.initSDocContext dynFlags @@ -661,20 +848,3 @@ printMessageDoc :: DynFlags -> MessageType -> Maybe Module -> String -> IO () printMessageDoc dynFlags = (fmap . fmap . fmap) (putDocLn dynFlags) messageDoc - --- --- Syscalls --- - -#if !defined(mingw32_HOST_OS) -hDataSync :: Handle -> IO () -hDataSync h = do - FD { fdFD } <- handleToFd h - throwErrnoIfMinus1_ "ghc-tags-plugin" (c_fdatasync fdFD) - -foreign import ccall safe "fdatasync" - c_fdatasync :: CInt -> IO CInt -#else -hDataSync :: Handle -> IO () -hDataSync _ = pure () -#endif diff --git a/lib/Plugin/GhcTags/FileLock.hs b/lib/Plugin/GhcTags/FileLock.hs --- a/lib/Plugin/GhcTags/FileLock.hs +++ b/lib/Plugin/GhcTags/FileLock.hs @@ -6,6 +6,7 @@ ) where import Control.Exception +import Control.Monad (when) #if !defined(mingw32_HOST_OS) import Lukko.FLock @@ -15,13 +16,17 @@ -- | 'flock' base lock (on posix) or `LockFileEx` on Windows. -- -withFileLock :: FilePath -> LockMode -> (FD -> IO x) -> IO x -withFileLock path mode k = +withFileLock :: Bool -- ^ debug option + -> FilePath -> LockMode -> (FD -> IO x) -> IO x +withFileLock debug path mode k = bracket (fdOpen path) (\h -> fdClose h) $ \h -> bracket - (fdLock h mode) - (\_ -> fdUnlock h) + (do fdLock h mode + when debug (putStrLn "lock: taken")) + (\_ -> + do when debug (putStrLn "lock: releasing") + fdUnlock h) (\_ -> k h) diff --git a/lib/Plugin/GhcTags/Options.hs b/lib/Plugin/GhcTags/Options.hs --- a/lib/Plugin/GhcTags/Options.hs +++ b/lib/Plugin/GhcTags/Options.hs @@ -21,6 +21,13 @@ <> showDefault <> help "produce emacs etags file" +streamParser :: Parser Bool +streamParser = switch $ + short 's' + <> long "stream" + <> showDefault + <> help ( "stream tags from the tags file when updating its contents" + ++ " with the tags found in the current module" ) filePathParser :: Parser (FilePath) filePathParser = @@ -40,9 +47,16 @@ { etags :: Bool -- ^ if 'True' use emacs tags file format, the default is 'False'. + , stream :: Bool + -- ^ be default we read the tags file and overwrite it. When this option + -- is on, we stream tags from it while interliving the tags found in the + -- current module to a new destination, which is then moved to the tags + -- file desintation. + , filePath :: f FilePath -- ^ file path to the tags file (relative to the @*.cabal@ file). The -- default is either 'tags' (if 'etags' if 'False') or 'TAGS' otherwise. + , debug :: Bool } @@ -53,6 +67,7 @@ parseOtions = Options <$> etagsParser -- allow to pass the argument multiple times + <*> streamParser <*> (foldMap (Last . Just) <$> many filePathParser) <*> debugParser @@ -68,9 +83,10 @@ runOptionParser = fmap defaultOptions . execParserPure defaultPrefs parserInfo where defaultOptions :: Options Last -> Options Identity - defaultOptions Options { etags, filePath, debug } = + defaultOptions Options { etags, stream, filePath, debug } = Options { etags, + stream, filePath = Identity filePath', debug }