ghc-tags-plugin 0.1.6.0 → 0.2.0.0
raw patch · 4 files changed
+260/−142 lines, 4 filesdep +filepath-bytestringdep +unixdep −pipes-text
Dependencies added: filepath-bytestring, unix
Dependencies removed: pipes-text
Files
- CHANGELOG.md +5/−0
- ghc-tags-plugin.cabal +6/−2
- lib/Plugin/GhcTags.hs +239/−138
- lib/Plugin/GhcTags/Options.hs +10/−2
CHANGELOG.md view
@@ -41,3 +41,8 @@ type of instances (instance context & instance head), types of `GADTs` constructors, rhs of type synonyms, kinds of type or data families. * expanded ctags pseudo tags with descriptions of fields and tag kinds++## 0.2.0.0 -- 2020-04-12++* Fixed bug #37+* Added `--debug` flag
ghc-tags-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-plugin-version: 0.1.6.0+version: 0.2.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)@@ -41,6 +41,8 @@ bytestring ^>=0.10, directory ^>=1.3, filepath ^>=1.4,+ filepath-bytestring+ ^>=1.4, ghc >=8.4 && <8.9, mtl ^>=2.2, optparse-applicative@@ -48,11 +50,13 @@ pipes ^>=4.3, pipes-attoparsec ^>=0.5, pipes-bytestring ^>=2.1,- pipes-text >=0.0.2 && <0.0.3 , pipes-safe ^>=2.3, text ^>=1.2, ghc-tags-core++ if !os(windows)+ build-depends: unix >=2.7.2.2 && < 2.8 default-language: Haskell2010 ghc-options: -Wall
lib/Plugin/GhcTags.hs view
@@ -4,16 +4,20 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Plugin.GhcTags ( plugin, Options (..) ) where import Control.Exception import Control.Monad.State.Strict+import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Builder as BB+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text #if __GLASGOW_HASKELL__ < 808 import Data.Functor (void, (<$)) #endif@@ -21,20 +25,25 @@ import Data.List (sortBy) import Data.Foldable (traverse_) import Data.Maybe (mapMaybe)-import Data.Text (Text)-import qualified Data.Text.Encoding as Text import System.Directory import System.FilePath+import System.FilePath.ByteString (RawFilePath)+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 System.Posix.Types (Fd (..))+import System.Posix.IO (handleToFd)+#endif+ import Options.Applicative.Types (ParserFailure (..)) -import Pipes ((~>)) import qualified Pipes as Pipes import Pipes.Safe (SafeT) import qualified Pipes.Safe as Pipes.Safe import qualified Pipes.ByteString as Pipes.BS-import qualified Pipes.Text.Encoding as Pipes.Text import GhcPlugins ( CommandLineOption , DynFlags@@ -111,197 +120,269 @@ -- | The plugin does not change the 'HsParedModule', it only runs side effects. -- ghcTagsPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule-ghcTagsPlugin options moduleSummary hsParsedModule@HsParsedModule {hpm_module} =+ghcTagsPlugin options+ moduleSummary@ModSummary {ms_mod, ms_hspp_opts = dynFlags}+ hsParsedModule@HsParsedModule {hpm_module} =+ hsParsedModule <$ case runOptionParser options of- Success opts -> GhcPlugins.liftIO (updateTags opts moduleSummary hpm_module)+ Success opts@Options { filePath = Identity tagsFile+ , debug+ } -> - Failure (ParserFailure f) -> GhcPlugins.liftIO $- putDocLn (ms_hspp_opts moduleSummary)- (messageDoc- OptionParserFailure- (ms_mod moduleSummary)- (show $ case f "<ghc-tags-plugin>" of (h, _, _) -> h))+ GhcPlugins.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 ms_mod (displayException ioerr))+ throwIO $ GhcTagsPluginIOExceptino ioerr) $+ flip finally (void $ try @IOException $ removeFile sourceFile) $+ -- 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 WriteMode $ \_ -> do+ mbInSize <-+ if debug+ then Just <$> getFileSize tagsFile+ `catch` \(_ :: IOException) -> pure 0+ else pure Nothing+ updateTags opts moduleSummary hpm_module sourceFile+ 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+ ])++ Failure (ParserFailure f) ->+ GhcPlugins.liftIO $+ putDocLn dynFlags+ (messageDoc+ OptionParserFailure+ ms_mod+ (show (case f "<ghc-tags-plugin>" of (h, _, _) -> h)+ ++ " " ++ show options))+ CompletionInvoked {} -> error "ghc-tags-plugin: impossible happend" -data ExceptionType =+data MessageType = ReadException | ParserException | WriteException | UnhandledException | OptionParserFailure+ | DebugMessage -instance Show ExceptionType where+instance Show MessageType where show ReadException = "read error" show ParserException = "tags parser error" show WriteException = "write error" show UnhandledException = "unhandled error" show OptionParserFailure = "plugin options parser error"+ show DebugMessage = "" -- | Extract tags from a module and update tags file -- updateTags :: Options Identity -> ModSummary -> Located (HsModule GhcPs)+ -> FilePath -> IO ()-updateTags Options { etags, filePath = Identity tagsFile }+updateTags Options { etags, filePath = Identity tagsFile, debug } ModSummary {ms_mod, ms_location, ms_hspp_opts = dynFlags}- lmodule =- -- wrap 'IOException's- handle (\ioerr -> do- putDocLn dynFlags (messageDoc UnhandledException ms_mod (displayException ioerr))- throwIO $ GhcTagsPluginIOExceptino ioerr) $- flip finally (void $ try @IOException $ removeFile sourceFile) $- -- 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 WriteMode $ \_ -> do- tagsFileExists <- doesFileExist tagsFile- when tagsFileExists- $ renameFile tagsFile sourceFile- withFile tagsFile WriteMode $ \writeHandle ->- withFile sourceFile ReadWriteMode $ \readHandle -> do- cwd <- getCurrentDirectory- -- absolute directory path of the tags file; we need canonical path- -- (without ".." and ".") to make 'makeRelative' works.- tagsDir <- canonicalizePath (fst $ splitFileName tagsFile)+ 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) - case (etags, ml_hs_file ms_location) of+ case (etags, ml_hs_file ms_location) of - --- -- ctags- --- (False, Nothing) -> pure ()- (False, Just sourcePath) -> do+ --+ -- ctags+ --+ (False, Nothing) -> pure ()+ (False, Just sourcePath) -> do - let -- text parser- producer :: Pipes.Producer Text (SafeT IO) ()- producer- | tagsFileExists =- void (Pipes.Text.decodeUtf8- (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 ms_mod (displayException e))- | otherwise = pure ()+ 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 ms_mod (displayException e))+ | otherwise = pure () - -- gags pipe- pipe :: Pipes.Effect (StateT [CTag] (SafeT IO)) ()- pipe =- Pipes.for- (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 ms_mod (displayException e)- )- $- -- normalise paths- (\tag -> Pipes.yield tag { tagFilePath = normalise (tagFilePath tag) })- ~>- -- merge tags- (\tag ->- runCombineTagsPipe writeHandle CTag.compareTags CTag.formatTag (fixFilePath cwd tagsDir sourcePath) 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 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 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 ms_mod (displayException e)+ ) - let tags :: [CTag]- tags = map (fixTagFilePath cwd tagsDir)- -- fix file names- . 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+ . 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'- tags' <- Pipes.Safe.runSafeT $ execStateT ((Pipes.runEffect pipe)) 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' - --- -- etags- --- (True, Nothing) -> pure ()- (True, Just sourcePath) ->- try @IOException (Text.decodeUtf8 <$> BS.hGetContents readHandle)- >>= \case- Left err ->- putDocLn dynFlags $ messageDoc ReadException ms_mod (displayException err)+ 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 - Right txt -> do- pres <- try @IOException $ ETag.parseTagsFile txt- case pres of- Left err -> - putDocLn dynFlags $ messageDoc ParserException ms_mod (displayException err)+ when debug+ $ printMessageDoc dynFlags DebugMessage ms_mod+ (concat [ "parsed: "+ , show parsedTags+ , " found: "+ , show (length tags)+ , " left: "+ , show (length tags')+ ]) - Right (Left err) ->- printMessageDoc dynFlags ParserException ms_mod err+ --+ -- etags+ --+ (True, Nothing) -> pure ()+ (True, Just sourcePath) ->+ try @IOException (BS.hGetContents readHandle)+ >>= \case+ Left err ->+ putDocLn dynFlags $ messageDoc ReadException ms_mod (displayException err) - Right (Right tags) -> do+ Right txt -> do+ pres <- try @IOException $ ETag.parseTagsFile txt+ case pres of+ Left err -> + putDocLn dynFlags $ messageDoc ParserException ms_mod (displayException err) - -- read the source file to calculate byteoffsets- ll <- map (succ . BS.length) . BSC.lines <$> BS.readFile sourcePath+ Right (Left err) ->+ printMessageDoc dynFlags ParserException ms_mod err - let tags' :: [ETag]- tags' = combineTags- ETag.compareTags- (fixFilePath cwd tagsDir sourcePath)- (sortBy ETag.compareTags- . map ( ETag.withByteOffset ll- . fixTagFilePath cwd tagsDir- )- . mapMaybe (ghcTagToTag SingETag dynFlags)- . getGhcTags- $ lmodule)- (sortBy ETag.compareTags tags)+ Right (Right tags) -> do - BB.hPutBuilder writeHandle (ETag.formatETagsFile tags')+ -- read the source file to calculate byteoffsets+ ll <- map (succ . BS.length) . BSC.lines <$> BS.readFile sourcePath + let sourcePathBS = Text.encodeUtf8 (Text.pack sourcePath) - where+ newTags :: [ETag]+ newTags =+ (sortBy ETag.compareTags+ . map ( ETag.withByteOffset ll+ . fixTagFilePath cwd tagsDir+ )+ . mapMaybe (ghcTagToTag SingETag dynFlags)+ . getGhcTags+ $ lmodule) - sourceFile = case splitFileName tagsFile of- (dir, name) -> dir </> "." ++ name- lockFile = sourceFile ++ ".lock"+ tags' :: [ETag]+ tags' = combineTags+ ETag.compareTags+ (fixFilePath cwd tagsDir sourcePathBS)+ newTags+ (sortBy ETag.compareTags tags) - fixFilePath :: FilePath -- curent directory- -> FilePath -- tags directory- -> FilePath -> FilePath- fixFilePath cwd tagsDir = normalise . makeRelative tagsDir . (cwd </>)+ when debug+ $ printMessageDoc dynFlags DebugMessage ms_mod+ (concat [ "parsed: "+ , show (length tags)+ , " found: "+ , show (length newTags)+ ]) - fixTagFilePath :: FilePath -> FilePath -> Tag tk -> Tag tk- fixTagFilePath cwd tagsDir tag@Tag { tagFilePath } =- tag { tagFilePath = fixFilePath cwd tagsDir tagFilePath }+ BB.hPutBuilder writeHandle (ETag.formatETagsFile tags') + where++ fixFilePath :: RawFilePath -- curent directory+ -> RawFilePath -- tags directory+ -> RawFilePath -> RawFilePath+ fixFilePath cwd tagsDir =+ FilePath.normalise+ . FilePath.makeRelative tagsDir+ . (cwd FilePath.</>)++ -- we are missing `Text` based `FilePath` library!+ fixTagFilePath :: RawFilePath -> RawFilePath -> Tag tk -> Tag tk+ fixTagFilePath cwd tagsDir tag@Tag { tagFilePath = TagFilePath fp } =+ tag { tagFilePath =+ TagFilePath+ (Text.decodeUtf8+ (fixFilePath cwd tagsDir+ (Text.encodeUtf8 fp)))+ }++ -- -- Error Formatting -- data MessageSeverity- = Warning+ = Debug+ | Warning | Error -messageDoc :: ExceptionType -> Module -> String -> Out.SDoc+messageDoc :: MessageType -> Module -> String -> Out.SDoc messageDoc errorType mod_ errorMessage = Out.blankLine $+$ Out.coloured PprColour.colBold ((Out.text "GhcTagsPlugin: ")- Out.<> (Out.coloured messageColour (Out.text $ show errorType ++ ":")))+ Out.<> (Out.coloured messageColour (Out.text $ show errorType))) $$ Out.coloured PprColour.colBold (Out.nest 4 $ Out.ppr mod_) $$@@ -314,6 +395,7 @@ Out.<> Out.text "https://github.com/coot/ghc-tags-plugin/issues" $+$ Out.blankLine Warning -> Out.blankLine+ Debug -> Out.blankLine where severity = case errorType of ReadException -> Error@@ -321,10 +403,12 @@ WriteException -> Error UnhandledException -> Error OptionParserFailure -> Warning+ DebugMessage -> Debug messageColour = case severity of Error -> PprColour.colRedFg Warning -> PprColour.colBlueFg+ Debug -> PprColour.colCyanFg putDocLn :: DynFlags -> Out.SDoc -> IO ()@@ -336,5 +420,22 @@ (Out.setStyleColoured True $ Out.defaultErrStyle dynFlags) -printMessageDoc :: DynFlags -> ExceptionType -> Module -> String -> IO ()+printMessageDoc :: DynFlags -> MessageType -> Module -> String -> IO () printMessageDoc dynFlags = (fmap . fmap . fmap) (putDocLn dynFlags) messageDoc++--+-- Syscalls+--++#if !defined(mingw32_HOST_OS)+hDataSync :: Handle -> IO ()+hDataSync h = do+ fd <- handleToFd h+ throwErrnoIfMinus1_ "ghc-tags-plugin" (c_fdatasync fd)++foreign import ccall safe "fdatasync"+ c_fdatasync :: Fd -> IO CInt +#else+hDataSync :: Handle -> IO ()+hDataSync _ = pure ()+#endif
lib/Plugin/GhcTags/Options.hs view
@@ -29,6 +29,11 @@ help "tags file: default tags or TAGS (when --etags is specified)" <> metavar "file_path" +debugParser :: Parser Bool+debugParser = switch $+ long "debug"+ <> showDefault+ <> help "debug" -- | /ghc-tags-plugin/ options --@@ -39,6 +44,7 @@ , 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 } deriving instance Show (Options Identity)@@ -49,6 +55,7 @@ <$> etagsParser -- allow to pass the argument multiple times <*> (foldMap (Last . Just) <$> many filePathParser)+ <*> debugParser parserInfo :: ParserInfo (Options Last)@@ -62,10 +69,11 @@ runOptionParser = fmap defaultOptions . execParserPure defaultPrefs parserInfo where defaultOptions :: Options Last -> Options Identity- defaultOptions Options { etags, filePath } =+ defaultOptions Options { etags, filePath, debug } = Options { etags,- filePath = Identity filePath'+ filePath = Identity filePath',+ debug } where filePath' =