ghc-tags-plugin 0.3.0.0 → 0.4.0.0
raw patch · 7 files changed
+458/−260 lines, 7 filesdep ~basedep ~lukko
Dependency ranges changed: base, lukko
Files
- CHANGELOG.md +5/−0
- README.md +4/−4
- app/check.hs +1/−1
- ghc-tags-plugin.cabal +6/−4
- lib/Plugin/GhcTags.hs +416/−246
- lib/Plugin/GhcTags/FileLock.hs +9/−4
- lib/Plugin/GhcTags/Options.hs +17/−1
CHANGELOG.md view
@@ -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.
README.md view
@@ -3,9 +3,7 @@   -[](https://github.com/coot/ghc-tags-plugin/actions)-[](https://github.com/coot/ghc-tags-plugin/actions)-[](https://github.com/coot/ghc-tags-plugin/actions)+[](https://github.com/coot/ghc-tags-plugin/actions/workflows/ci.yml) [](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: <program> [-e|--etags] [file_path]+Usage: <program> [-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
app/check.hs view
@@ -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
ghc-tags-plugin.cabal view
@@ -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
lib/Plugin/GhcTags.hs view
@@ -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 "<ghc-tags-plugin>" of (h, _, _) -> h)- ++ " " ++ show options))+ Failure (ParserFailure f) ->+ withMetaD defaultRunMeta request expr $ \_ ->+ liftIO $+ putDocLn dynFlags+ (messageDoc+ OptionParserFailure+ Nothing+ (show (case f "<ghc-tags-plugin>" 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
lib/Plugin/GhcTags/FileLock.hs view
@@ -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)
lib/Plugin/GhcTags/Options.hs view
@@ -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 }