diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.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 diff --git a/lib/Plugin/GhcTags.hs b/lib/Plugin/GhcTags.hs --- a/lib/Plugin/GhcTags.hs +++ b/lib/Plugin/GhcTags.hs @@ -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 "" 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 "" 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 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 @@ -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' =