diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -51,3 +51,8 @@ * Generate tags for template haskell splices (requires at least `GHC-8.10`). * Include types of class methods. + +## 0.2.4.0 -- 2020-09-08 + +* `ghc-tags-vim` a vim plugin which helps to maintain a `cabal.project.local` file. +* better tag info 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.2.3.0 +version: 0.2.4.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) diff --git a/lib/Plugin/GhcTags.hs b/lib/Plugin/GhcTags.hs --- a/lib/Plugin/GhcTags.hs +++ b/lib/Plugin/GhcTags.hs @@ -101,7 +101,7 @@ -- compiled module. -- -- __The syntax tree is left unchanged.__ --- +-- -- The tags file will contain location information about: -- -- * /top level terms/ @@ -119,7 +119,7 @@ -- plugin :: Plugin plugin = GhcPlugins.defaultPlugin { - parsedResultAction = ghcTagsPlugin, + parsedResultAction = ghcTagsParserPlugin, #if __GLASGOW_HASKELL__ >= 810 dynflagsPlugin = ghcTagsDynflagsPlugin, #endif @@ -130,8 +130,9 @@ -- | IOExcption wrapper; it is useful for the user to know that it's the plugin -- not `ghc` that thrown the error. -- -data GhcTagsPluginException = - GhcTagsPluginIOExceptino IOException +data GhcTagsPluginException + = GhcTagsParserPluginIOException IOException + | GhcTagsDynFlagsPluginIOException IOException deriving Show instance Exception GhcTagsPluginException @@ -139,10 +140,10 @@ -- | The plugin does not change the 'HsParedModule', it only runs side effects. -- -ghcTagsPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule -ghcTagsPlugin options - moduleSummary@ModSummary {ms_mod, ms_hspp_opts = dynFlags} - hsParsedModule@HsParsedModule {hpm_module} = +ghcTagsParserPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule +ghcTagsParserPlugin options + moduleSummary@ModSummary {ms_mod, ms_hspp_opts = dynFlags} + hsParsedModule@HsParsedModule {hpm_module} = hsParsedModule <$ case runOptionParser options of @@ -157,8 +158,10 @@ -- wrap 'IOException's handle (\ioerr -> do - putDocLn dynFlags (messageDoc UnhandledException (Just ms_mod) (displayException ioerr)) - throwIO $ GhcTagsPluginIOExceptino ioerr) $ + putDocLn dynFlags + (messageDoc UnhandledException (Just ms_mod) + (displayException ioerr)) + throwIO (GhcTagsParserPluginIOException 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. @@ -177,7 +180,7 @@ when (inSize > outSize) $ throwIO (userError $ concat [ "tags file '" - , tagsFile + , tagsFile , "' size shrinked: " , show inSize , "→" @@ -204,6 +207,7 @@ | OptionParserFailure | DebugMessage + instance Show MessageType where show ReadException = "read error" show ParserException = "tags parser error" @@ -212,6 +216,7 @@ show OptionParserFailure = "plugin options parser error" show DebugMessage = "" + -- | Extract tags from a module and update tags file -- updateTags :: Options Identity @@ -325,7 +330,7 @@ Right txt -> do pres <- try @IOException $ ETag.parseTagsFile txt case pres of - Left err -> + Left err -> putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException err) Right (Left err) -> @@ -366,27 +371,6 @@ 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))) - } - - #if __GLASGOW_HASKELL__ >= 810 -- -- Tags for Template-Haskell splices @@ -413,13 +397,21 @@ lockFile = sourceFile ++ ".lock" withMetaD defaultRunMeta request expr $ \decls -> - GhcPlugins.liftIO $ withFileLock lockFile ExclusiveLock $ \_ -> do + GhcPlugins.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 -> + Left err -> printMessageDoc dynFlags ParserException Nothing err Right tags -> do @@ -427,7 +419,8 @@ tags' = sortBy ETag.compareTags $ tags ++ - ghcTagToTag SingETag dynFlags + (fmap (fixTagFilePath cwd tagsDir) + . ghcTagToTag SingETag dynFlags) `mapMaybe` hsDeclsToGhcTags Nothing decls BSL.writeFile tagsFile (BB.toLazyByteString $ ETag.formatTagsFile tags') @@ -441,13 +434,14 @@ let tags' :: [Either CTag.Header CTag] tags' = Left `map` headers ++ Right `map` - sortBy CTag.compareTags - ( tags - ++ - ghcTagToTag SingCTag dynFlags - `mapMaybe` - hsDeclsToGhcTags Nothing decls - ) + 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) -> @@ -476,10 +470,42 @@ MetaAW k -> k <$> GhcPlugins.metaRequestAW h e #endif + -- --- Error Formatting +-- File path utils -- +fixFilePath :: RawFilePath + -- ^ curent directory + -> RawFilePath + -- ^ tags file directory + -> RawFilePath + -- ^ tag's file path + -> RawFilePath +fixFilePath cwd tagsDir = + FilePath.normalise + . FilePath.makeRelative tagsDir + . (cwd FilePath.) + + +-- we are missing `Text` based `FilePath` library! +fixTagFilePath :: RawFilePath + -- ^ current directory + -> RawFilePath + -- ^ tags file directory + -> Tag tk -> Tag tk +fixTagFilePath cwd tagsDir tag@Tag { tagFilePath = TagFilePath fp } = + tag { tagFilePath = + TagFilePath + (Text.decodeUtf8 + (fixFilePath cwd tagsDir + (Text.encodeUtf8 fp))) + } + +-- +-- Error Formattng +-- + data MessageSeverity = Debug | Warning @@ -546,7 +572,7 @@ throwErrnoIfMinus1_ "ghc-tags-plugin" (c_fdatasync fdFD) foreign import ccall safe "fdatasync" - c_fdatasync :: CInt -> IO CInt + c_fdatasync :: CInt -> IO CInt #else hDataSync :: Handle -> IO () hDataSync _ = pure ()