ghc-tags-plugin 0.1.0.2 → 0.1.1.0
raw patch · 8 files changed
+463/−255 lines, 8 filesdep +ghc-tags-plugindep +gitrevPVP ok
version bump matches the API change (PVP)
Dependencies added: ghc-tags-plugin, gitrev
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- README.md +8/−4
- ghc-tags-plugin.cabal +20/−3
- lib/Plugin/GhcTags.hs +0/−192
- lib/Plugin/GhcTags/Generate.hs +127/−40
- lib/Plugin/GhcTags/Parser.hs +84/−16
- lib/Plugin/GhcTags/Vim.hs +54/−0
- src/Plugin/GhcTags.hs +165/−0
CHANGELOG.md view
@@ -3,3 +3,8 @@ ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world.++## 0.1.1.0 -- 2020-03-03++* Added support for tag's kinds.+* Added various file headers
README.md view
@@ -39,10 +39,12 @@ In `cabal.project.local` file add `package` stanza for every local package : ``` project some-project- ghc-options: -package-db=PACKAGE_DB -plugin-package=ghc-tags-plugin -fplugin=Plugin.GhcTags+ ghc-options: -package-db=PACKAGE_DB+ -plugin-package=ghc-tags-plugin+ -fplugin=Plugin.GhcTags ``` -`PACKAGE_DB` is likely something to be something like (for `ghc-8.6.5`)+`PACKAGE_DB` is likely to be something like (for `ghc-8.6.5`) '${HOME}/.cabal/store/ghc-8.6.5/package.db' (all environment variables must be expanded). @@ -57,7 +59,9 @@ In `stack.yaml` file add: ``` ghc-options:- some-project: -package-db=PACKAGE_DB -plugin-package=ghc-tags-plugin -fplugin=Plugin.GhcTags+ some-project: -package-db=PACKAGE_DB+ -plugin-package=ghc-tags-plugin+ -fplugin=Plugin.GhcTags ``` where `PACKAGE_DB` is the package db where `ghc-tags-plugin` was installed by@@ -66,7 +70,7 @@ ## modifying `cabal` files You can always add `ghc-tags-plugin` as a build dependency in a cabal file (for-each component). You can hide it behind a flag and then use `cabal` or `stack`+each component). You should hide it behind a flag and then use `cabal` or `stack` to enable it (or `cabal.project.local` or `stack.yaml` files for that purpose). # Security implications of compiler plugins
ghc-tags-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-tags-plugin-version: 0.1.0.2+version: 0.1.1.0 synopsis: A compiler plugin which generates tags file from GHC syntax tree. description: A compiler source plugin which takes parsed Haskell syntax tree and saves@@ -21,15 +21,32 @@ location: https://github.com/coot/ghc-tags-plugin library+ hs-source-dirs: src exposed-modules: Plugin.GhcTags- other-modules: Plugin.GhcTags.Generate+ build-depends: base ^>=4.12.0.0,+ containers ^>=0.6,+ directory ^>=1.3,+ bytestring ^>=0.10,+ ghc >=8.4 && <8.9,+ gitrev ^>=1.3,++ ghc-tags-library++ default-language: Haskell2010+ ghc-options: -Wall++library ghc-tags-library+ hs-source-dirs: lib+ exposed-modules: Plugin.GhcTags.Generate Plugin.GhcTags.Parser+ Plugin.GhcTags.Vim+ Paths_ghc_tags_plugin+ autogen-modules: Paths_ghc_tags_plugin build-depends: base ^>=4.12.0.0, attoparsec ^>=0.13.0.0, containers ^>=0.6, directory ^>=1.3, bytestring ^>=0.10, ghc >=8.4 && <8.9- hs-source-dirs: lib default-language: Haskell2010 ghc-options: -Wall
− lib/Plugin/GhcTags.hs
@@ -1,192 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Plugin.GhcTags ( plugin ) where--import Control.Concurrent-import Control.Exception-import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BS-import Data.Functor ((<$))-import Data.List (sort)-import qualified Data.Map as Map-import Data.Maybe (mapMaybe)--- import Data.Foldable (traverse_)-import System.IO-import System.IO.Error (tryIOError)-import System.IO.Unsafe (unsafePerformIO)-import System.Directory--import GhcPlugins ( CommandLineOption- , Hsc- , HsParsedModule (..)- , ModSummary- , Plugin (..)- , liftIO- , purePlugin- )-import GhcPlugins hiding (occName, (<>))-import HsExtension (GhcPs)-import HsSyn (HsModule)--import Plugin.GhcTags.Generate-import Plugin.GhcTags.Parser----- | Global shared state which persists across compilation of different--- modules - a nasty hack which is only used for optimzation.----tagsMVar :: MVar (Maybe TagsMap)-tagsMVar = unsafePerformIO $ newMVar Nothing---- | The GhcTags plugin. It will run for every compiled module and have access--- to parsed syntax tree. It will inpect it and:------ * update a global mutable state variable, which stores a tag map.--- It is shared accross modules compiled in the same `ghc` run.--- * update 'tags' file. ------ The global mutable variable save us from parsing the tags file for every--- compiled module.------ __The syntax tree is left unchanged.__--- --- The tags file will contain location information about:------ * top level terms--- * type classes--- * type class members--- * type class instances--- * type families /(standalone and associated)/--- * type family instances /(standalone and associated)/--- * data type families /(standalone and associated)/--- * data type families instances /(standalone and associated)/--- * data type family instances constructors /(standalone and associated)/----plugin :: Plugin-plugin = GhcPlugins.defaultPlugin {- parsedResultAction = ghcTagPlugin,- pluginRecompile = purePlugin- }----- | The plugin does not change the 'HsParedModule', it only runs side effects.----ghcTagPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule-ghcTagPlugin options _modSummary hsParsedModule@HsParsedModule {hpm_module} =- hsParsedModule <$ liftIO (updateTags tagsFile hpm_module)- where- tagsFile :: FilePath- tagsFile = case options of- [] -> "tags"- a : _ -> a----- | Extract tags from a module and update tags file as well as the 'tagsMVar'--- Using 'tagsMVar' we can save on parsing the tags file: we do it only when--- the first module is compiled. We need to write the results at every--- compilation step since we don't know if the currently compiled module is the--- last one or not.----updateTags :: FilePath- -> Located (HsModule GhcPs)- -> IO ()-updateTags tagsFile lmodule =- -- Take exclusive lock. This assures that only one thread will have access to- -- the tags file. Parsing and the rest of the compilation pipeline can- -- happen concurrently.- mvarLock tagsMVar $ \mTagsMap -> do- (tagsMap :: TagsMap) <-- case mTagsMap of-- Nothing -> do- a <- doesFileExist tagsFile- res <-- if a- then do- mbytes <- tryIOError (BS.readFile tagsFile)- case mbytes of- Left err -> do- putStrLn $ "GhcTags: error reading \"" ++ tagsFile ++ "\": " ++ (show err)- return $ Right []- Right bytes ->- parseVimTagFile bytes- else return $ Right []- case res of- Left err -> do- putStrLn $ "GhcTags: error reading or parsing \"" ++ tagsFile ++ "\": " ++ err- return $ Map.empty- Right tagList -> do- return $ mkTagsMap tagList-- Just tagsMap -> return tagsMap-- let tagsMap', updatedTagsMap :: TagsMap- tagsMap' =- mkTagsMap- $ mapMaybe ghcTagToTag- $ generateTagsForModule- $ lmodule-- updatedTagsMap = tagsMap' `Map.union` tagsMap-- {-- putStrLn $ "tags found"- traverse_ print- $ sortOn tagName- $ concat- $ Map.elems tagsMap'- -}-- -- update 'tagsIORef', make sure that `updateTagsMap` is evaluated.- -- TODO: this is not attomic, which will break when compiling multiple- -- modules at the same time. I think we need to use 'MVar' and- -- 'takeMVar'.-- -- update tags file- withFile tagsFile WriteMode $ \fhandle ->- BS.hPutBuilder fhandle- $ foldMap formatVimTag- $ sort- $ concat- $ Map.elems updatedTagsMap-- return $ updatedTagsMap `seq` Just updatedTagsMap----- | The 'MVar' is used as an exlusive lock. Also similar to 'bracket' but--- updates the 'MVar' with returned value, or put the original value if an--- exception is thrown by the continuation (or an async exception).----mvarLock :: MVar a- -> (a -> IO a)- -> IO ()-mvarLock v k = mask $ \unmask -> do- a <- takeMVar v- a' <- unmask (k a)- `onException`- putMVar v a- putMVar v $! a'---ghcTagToTag :: GhcTag -> Maybe Tag-ghcTagToTag GhcTag { tagSrcSpan, tagTag } =- case tagSrcSpan of- UnhelpfulSpan {} -> Nothing- RealSrcSpan realSrcSpan ->- Just $ Tag { tagName = TagName (fs_bs tagTag)- , tagFile = TagFile (fs_bs (srcSpanFile realSrcSpan))- , tagLine = srcSpanStartLine realSrcSpan- }---formatVimTag :: Tag -> Builder-formatVimTag Tag { tagName, tagFile, tagLine } =- BS.byteString (getTagName tagName)- <> BS.charUtf8 '\t'- <> BS.byteString (getTagFile tagFile)- <> BS.charUtf8 '\t'- <> BS.intDec tagLine- <> BS.charUtf8 '\n'
lib/Plugin/GhcTags/Generate.hs view
@@ -7,7 +7,10 @@ module Plugin.GhcTags.Generate ( GhcTag (..) , GhcTags- , generateTagsForModule+ , TagKind (..)+ , tagKindToChar+ , charToTagKind+ , getGhcTags ) where import Data.Maybe (mapMaybe)@@ -25,6 +28,7 @@ , DataFamInstDecl (..) , FamEqn (..) , FamilyDecl (..)+ , FamilyInfo (..) , ForeignDecl (..) , LHsDecl , HsConDeclDetails@@ -58,12 +62,81 @@ ) +-- | `ctags` can generate tags kind, so do we.+--+data TagKind = TkTerm+ | TkFunction+ | TkTypeConstructor+ | TkDataConstructor+ | TkGADTConstructor+ | TkRecordField+ | TkTypeSynonym+ | TkTypeSignature+ | TkPatternSynonym+ | TkTypeClass+ | TkTypeClassMember+ | TkTypeClassInstance+ | TkTypeFamily+ | TkTypeFamilyInstance+ | TkDataTypeFamily+ | TkDataTypeFamilyInstance+ | TkForeignImport+ | TkForeignExport+ deriving (Ord, Eq, Show)+++tagKindToChar :: TagKind -> Char+tagKindToChar tagKind = case tagKind of+ TkTerm -> 'x'+ TkFunction -> 'l' -- we should use 'λ' but vim is not showing them in a right way+ TkTypeConstructor -> 't'+ TkDataConstructor -> 'c'+ TkGADTConstructor -> 'g'+ TkRecordField -> 'r'+ TkTypeSynonym -> 'S'+ TkTypeSignature -> 's'+ TkPatternSynonym -> 'p'+ TkTypeClass -> 'C'+ TkTypeClassMember -> 'm'+ TkTypeClassInstance -> 'i'+ TkTypeFamily -> 'f'+ TkTypeFamilyInstance -> 'F'+ TkDataTypeFamily -> 'd'+ TkDataTypeFamilyInstance -> 'D'+ TkForeignImport -> 'I'+ TkForeignExport -> 'E'+++charToTagKind :: Char -> Maybe TagKind+charToTagKind c = case c of+ 'x' -> Just TkTerm+ 'l' -> Just TkFunction+ 't' -> Just TkTypeConstructor+ 'c' -> Just TkDataConstructor+ 'g' -> Just TkGADTConstructor+ 'r' -> Just TkRecordField+ 'S' -> Just TkTypeSynonym+ 's' -> Just TkTypeSignature+ 'p' -> Just TkPatternSynonym+ 'C' -> Just TkTypeClass+ 'm' -> Just TkTypeClassMember+ 'i' -> Just TkTypeClassInstance+ 'f' -> Just TkTypeFamily+ 'F' -> Just TkTypeFamilyInstance+ 'd' -> Just TkDataTypeFamily+ 'D' -> Just TkDataTypeFamilyInstance+ 'I' -> Just TkForeignImport+ 'E' -> Just TkForeignExport+ _ -> Nothing++ -- | We can read names from using fields of type 'GHC.Hs.Extensions.IdP' (a tpye -- family) which for @'Parsed@ resolved to 'RdrName' -- data GhcTag = GhcTag {- tagSrcSpan :: !SrcSpan- , tagTag :: !FastString+ gtSrcSpan :: !SrcSpan+ , gtTag :: !FastString+ , gtKind :: !TagKind } deriving Show @@ -71,28 +144,33 @@ mkGhcTag :: Located RdrName -- Located (IdP GhcPs)+ -> TagKind -> GhcTag-mkGhcTag (L tagSrcSpan rdrName) =+mkGhcTag (L gtSrcSpan rdrName) gtKind = case rdrName of Unqual occName ->- GhcTag { tagTag = occNameFS occName- , tagSrcSpan+ GhcTag { gtTag = occNameFS occName+ , gtSrcSpan+ , gtKind } Qual _ occName ->- GhcTag { tagTag = occNameFS occName- , tagSrcSpan+ GhcTag { gtTag = occNameFS occName+ , gtSrcSpan+ , gtKind } -- Orig is the only one we are interested in Orig _ occName ->- GhcTag { tagTag = occNameFS occName- , tagSrcSpan+ GhcTag { gtTag = occNameFS occName+ , gtSrcSpan+ , gtKind } Exact name -> - GhcTag { tagTag = occNameFS $ nameOccName name- , tagSrcSpan+ GhcTag { gtTag = occNameFS $ nameOccName name+ , gtSrcSpan+ , gtKind } @@ -101,6 +179,9 @@ -- -- Supported identifiers: -- * top level terms+-- * data types+-- * record fields+-- * type synonyms -- * type classes -- * type class members -- * type class instances@@ -110,9 +191,9 @@ -- * data type families instances -- * data type family instances constructors ---generateTagsForModule :: Located (HsModule GhcPs)+getGhcTags :: Located (HsModule GhcPs) -> GhcTags-generateTagsForModule (L _ HsModule { hsmodDecls }) = +getGhcTags (L _ HsModule { hsmodDecls }) = reverse $ foldl' go [] hsmodDecls where go :: GhcTags -> LHsDecl GhcPs -> GhcTags@@ -126,21 +207,21 @@ Nothing -> tags SynDecl { tcdLName } ->- mkGhcTag tcdLName : tags+ mkGhcTag tcdLName TkTypeSynonym : tags DataDecl { tcdLName, tcdDataDefn } -> case tcdDataDefn of HsDataDefn { dd_cons } ->- mkGhcTag tcdLName : ((mkConsTags . unLoc) `concatMap` dd_cons)- ++ tags+ mkGhcTag tcdLName TkTypeConstructor+ : (mkConsTags . unLoc) `concatMap` dd_cons+ ++ tags - XHsDataDefn {} ->- tags+ XHsDataDefn {} -> tags -- TODO: add 'tcdATDefs' ClassDecl { tcdLName, tcdSigs, tcdMeths, tcdATs } -> -- class name- mkGhcTag tcdLName+ mkGhcTag tcdLName TkTypeClass -- class methods : (mkSigTags . unLoc) `concatMap` tcdSigs -- default methods@@ -198,9 +279,9 @@ -- foreign declaration ForD _ foreignDecl -> case foreignDecl of- ForeignImport { fd_name } -> mkGhcTag fd_name : tags+ ForeignImport { fd_name } -> mkGhcTag fd_name TkForeignImport : tags - ForeignExport { fd_name } -> mkGhcTag fd_name : tags+ ForeignExport { fd_name } -> mkGhcTag fd_name TkForeignExport : tags XForeignDecl {} -> tags @@ -220,12 +301,12 @@ -- tags of all constructors of a type mkConsTags :: ConDecl GhcPs -> GhcTags mkConsTags ConDeclGADT { con_names, con_args } =- mkGhcTag `map` con_names+ flip mkGhcTag TkGADTConstructor `map` con_names ++ mkHsConDeclDetails con_args mkConsTags ConDeclH98 { con_name, con_args } =- mkGhcTag con_name+ mkGhcTag con_name TkDataConstructor : mkHsConDeclDetails con_args- mkConsTags XConDecl {} = []+ mkConsTags XConDecl {} = [] mkHsConDeclDetails :: HsConDeclDetails GhcPs -> GhcTags mkHsConDeclDetails (RecCon (L _ fields)) = foldl' f [] fields@@ -235,7 +316,7 @@ f ts _ = ts g :: GhcTags -> LFieldOcc GhcPs -> GhcTags- g ts (L _ FieldOcc { rdrNameFieldOcc }) = mkGhcTag rdrNameFieldOcc : ts+ g ts (L _ FieldOcc { rdrNameFieldOcc }) = mkGhcTag rdrNameFieldOcc TkRecordField : ts g ts _ = ts mkHsConDeclDetails _ = []@@ -243,7 +324,7 @@ mkHsBindLRTags :: HsBindLR GhcPs GhcPs -> GhcTags mkHsBindLRTags hsBind = case hsBind of- FunBind { fun_id } -> [mkGhcTag fun_id]+ FunBind { fun_id } -> [mkGhcTag fun_id TkFunction] -- TODO -- This is useful fo generating tags for@@ -252,20 +333,20 @@ -- ``` PatBind {} -> [] - VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag (L srcSpan var_id)]+ VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag (L srcSpan var_id) TkTerm] -- abstraction binding are only used after translaction AbsBinds {} -> [] - PatSynBind _ PSB { psb_id } -> [mkGhcTag psb_id]+ PatSynBind _ PSB { psb_id } -> [mkGhcTag psb_id TkPatternSynonym] PatSynBind _ XPatSynBind {} -> [] XHsBindsLR {} -> [] mkSigTags :: Sig GhcPs -> GhcTags- mkSigTags (TypeSig _ lhs _) = mkGhcTag `map` lhs- mkSigTags (PatSynSig _ lhs _) = mkGhcTag `map` lhs- mkSigTags (ClassOpSig _ _ lhs _) = mkGhcTag `map` lhs+ mkSigTags (TypeSig _ lhs _) = flip mkGhcTag TkTypeSignature `map` lhs+ mkSigTags (PatSynSig _ lhs _) = flip mkGhcTag TkPatternSynonym `map` lhs+ mkSigTags (ClassOpSig _ _ lhs _) = flip mkGhcTag TkTypeClassMember `map` lhs mkSigTags IdSig {} = [] -- TODO: generate theses with additional info (fixity) mkSigTags FixSig {} = []@@ -281,9 +362,15 @@ mkSigTags CompleteMatchSig {} = [] mkSigTags XSig {} = [] - mkFamilyDeclTags :: FamilyDecl GhcPs -> Maybe GhcTag- mkFamilyDeclTags FamilyDecl { fdLName } = Just $ mkGhcTag fdLName- mkFamilyDeclTags XFamilyDecl {} = Nothing+ mkFamilyDeclTags :: FamilyDecl GhcPs+ -> Maybe GhcTag+ mkFamilyDeclTags FamilyDecl { fdLName, fdInfo } = Just $ mkGhcTag fdLName tk+ where+ tk = case fdInfo of+ DataFamily -> TkDataTypeFamily+ OpenTypeFamily -> TkTypeFamily+ ClosedTypeFamily {} -> TkTypeFamily+ mkFamilyDeclTags XFamilyDecl {} = Nothing -- used to generate tag of an instance declaration mkLHsTypeTag :: LHsType GhcPs -> Maybe GhcTag@@ -293,10 +380,10 @@ HsQualTy {hst_body} -> mkLHsTypeTag hst_body - HsTyVar _ _ a -> Just $ mkGhcTag a+ HsTyVar _ _ a -> Just $ mkGhcTag a TkTypeClassInstance HsAppTy _ a _ -> mkLHsTypeTag a- HsOpTy _ _ a _ -> Just $ mkGhcTag a+ HsOpTy _ _ a _ -> Just $ mkGhcTag a TkTypeClassInstance HsKindSig _ a _ -> mkLHsTypeTag a _ -> Nothing@@ -310,9 +397,9 @@ HsIB { hsib_body = FamEqn { feqn_tycon, feqn_rhs } } -> case feqn_rhs of HsDataDefn { dd_cons } ->- mkGhcTag feqn_tycon : (mkConsTags . unLoc) `concatMap` dd_cons+ mkGhcTag feqn_tycon TkDataTypeFamilyInstance : (mkConsTags . unLoc) `concatMap` dd_cons XHsDataDefn {} ->- mkGhcTag feqn_tycon : []+ mkGhcTag feqn_tycon TkDataTypeFamilyInstance : [] HsIB { hsib_body = XFamEqn {} } -> [] @@ -322,6 +409,6 @@ XHsImplicitBndrs {} -> Nothing -- TODO: should we check @feqn_rhs :: LHsType GhcPs@ as well?- HsIB { hsib_body = FamEqn { feqn_tycon } } -> Just $ mkGhcTag feqn_tycon+ HsIB { hsib_body = FamEqn { feqn_tycon } } -> Just $ mkGhcTag feqn_tycon TkTypeFamilyInstance HsIB { hsib_body = XFamEqn {} } -> Nothing
lib/Plugin/GhcTags/Parser.hs view
@@ -1,31 +1,48 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-} module Plugin.GhcTags.Parser ( -- * Tag TagName (..) , TagFile (..) , Tag (..)+ , ghcTagToTag -- * Parsing , parseVimTagFile- -- * TagsMap+ -- * TagsMap' , TagsMap , mkTagsMap ) where +import Control.Applicative (many) import Data.ByteString (ByteString)-import Data.ByteString.Internal (c2w)+import qualified Data.ByteString.Char8 as BSC import Data.Attoparsec.ByteString (Parser)-import qualified Data.Attoparsec.ByteString as Atto-import qualified Data.Attoparsec.ByteString.Char8 as Atto ( decimal- , endOfLine- )+import qualified Data.Attoparsec.ByteString as A+import Data.Attoparsec.ByteString.Char8 ( (<?>) )+import qualified Data.Attoparsec.ByteString.Char8 as AC+import Data.Either (rights) import Data.List (sort)+import Data.Functor (void) import Data.Map (Map) import qualified Data.Map as Map +-- GHC imports+import Plugin.GhcTags.Generate+ ( GhcTag (..)+ , TagKind+ , charToTagKind+ )+import FastString ( FastString (..)+ )+import SrcLoc ( SrcSpan (..)+ , srcSpanFile+ , srcSpanStartLine+ ) + -- -- Tag --@@ -52,10 +69,23 @@ { tagName :: !TagName , tagFile :: !TagFile , tagLine :: !Int+ , tagKind :: !(Maybe TagKind) } deriving (Ord, Eq, Show) +ghcTagToTag :: GhcTag -> Maybe Tag+ghcTagToTag GhcTag { gtSrcSpan, gtTag, gtKind } =+ case gtSrcSpan of+ UnhelpfulSpan {} -> Nothing+ RealSrcSpan realSrcSpan ->+ Just $ Tag { tagName = TagName (fs_bs gtTag)+ , tagFile = TagFile (fs_bs (srcSpanFile realSrcSpan))+ , tagLine = srcSpanStartLine realSrcSpan+ , tagKind = Just gtKind+ }++ -- -- Parsing --@@ -63,27 +93,65 @@ -- | Parser for a single line of a vim-style tag file. ---vimTagLineParser:: Parser Tag-vimTagLineParser =- Tag <$> (TagName <$> Atto.takeWhile (/= tab) <* Atto.skipWhile (== tab))- <*> (TagFile <$> Atto.takeWhile (/= tab) <* Atto.skipWhile (== tab))- <*> Atto.decimal- where- tab = c2w '\t'+vimTagParser:: Parser Tag+vimTagParser = do+ -- use monadic form to provide compatibility with previous version where+ -- `;"` and tag kinds where not present.+ tagName <-+ TagName <$> AC.takeWhile (/= '\t') <* AC.skipWhile (== '\t')+ <?> "parsing tag name failed"+ tagFile <-+ TagFile <$> AC.takeWhile (/= '\t') <* AC.skipWhile (== '\t')+ <?> "parsing tag file name failed"+ tagLine <- AC.decimal+ <?> "parsing line number failed"+ + mc <- AC.peekChar+ tagKind <-+ case mc of+ Just ';' ->+ charToTagKind+ <$> (AC.anyChar *> AC.char '"' *> AC.char '\t' *> AC.anyChar)+ <?> "parsing tag kind failed"+ _ -> pure Nothing+ AC.endOfLine+ pure $ Tag {tagName, tagFile, tagLine, tagKind} + -- | A vim-style tag file parser. -- vimTagFileParser :: Parser [Tag]-vimTagFileParser = Atto.sepBy vimTagLineParser Atto.endOfLine+vimTagFileParser = rights <$> many tagLineParser +tagLineParser :: Parser (Either () Tag)+tagLineParser =+ AC.eitherP+ (vimTagHeaderLine <?> "failed parsing tag")+ (vimTagParser <?> "failed parsing header")+++vimTagHeaderLine :: Parser ()+vimTagHeaderLine = AC.choice+ [ AC.string (BSC.pack "!_TAG_FILE_FORMAT") *> params+ , AC.string (BSC.pack "!_TAG_FILE_SORTED") *> params+ , AC.string (BSC.pack "!_TAG_FILE_ENCODING") *> params+ , AC.string (BSC.pack "!_TAG_PROGRAM_AUTHOR") *> params+ , AC.string (BSC.pack "!_TAG_PROGRAM_NAME") *> params+ , AC.string (BSC.pack "!_TAG_PROGRAM_URL") *> params+ , AC.string (BSC.pack "!_TAG_PROGRAM_VERSION") *> params+ ]+ where++ params = void $ AC.char '\t' *> AC.skipWhile (/= '\n') *> AC.char '\n'+ -- | Parse a vim-style tag file. -- parseVimTagFile :: ByteString -> IO (Either String [Tag]) parseVimTagFile =- fmap Atto.eitherResult- . Atto.parseWith (pure mempty) vimTagFileParser+ fmap A.eitherResult+ . A.parseWith (pure mempty) vimTagFileParser --
+ lib/Plugin/GhcTags/Vim.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NamedFieldPuns #-}++module Plugin.GhcTags.Vim+ ( formatVimTag+ , formatVimTagFile+ ) where++import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BS+import Data.Version (showVersion)+import Text.Printf (printf)++import Paths_ghc_tags_plugin (version)++import Plugin.GhcTags.Generate+import Plugin.GhcTags.Parser+++-- | 'ByteString' 'Builder' for a single line.+--+formatVimTag :: Tag -> Builder+formatVimTag Tag { tagName, tagFile, tagLine, tagKind } =+ BS.byteString (getTagName tagName)+ <> BS.charUtf8 '\t'+ <> BS.byteString (getTagFile tagFile)+ <> BS.charUtf8 '\t'+ <> BS.intDec tagLine+ <> case tagKind of+ Just k ->+ BS.stringUtf8 ";\"\t"+ <> BS.charUtf8 (tagKindToChar k)+ Nothing -> mempty+ <> BS.charUtf8 '\n'+++-- | 'ByteString' 'Builder' for vim 'Tag' file.+--+formatVimTagFile :: [Tag] -> Builder+formatVimTagFile tags =+ -- format 1 does not append ';"' to lines+ BS.stringUtf8 (formatHeader "TAG_FILE_FORMAT" "2")+ -- allows for binary search+ <> BS.stringUtf8 (formatHeader "TAG_FILE_SORTED" "1")+ <> BS.stringUtf8 (formatHeader "TAG_FILE_ENCODING" "utf-8")+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_AUTHOR" "Marcin Szamotulski")+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_NAME" "ghc-tags-pluginn")+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_URL"+ "https://hackage.haskell.org/package/ghc-tags-plugin")+ -- version number with git revision+ <> BS.stringUtf8 (formatHeader "TAG_PROGRAM_VERSION" (showVersion version))+ <> foldMap formatVimTag tags+ where+ formatHeader :: String -> String -> String+ formatHeader header arg = printf ("!_" ++ header ++ "\t%s\t\n") arg
+ src/Plugin/GhcTags.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Plugin.GhcTags ( plugin ) where++import Control.Concurrent+import Control.Exception+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BS+import Data.Functor ((<$))+import Data.List (sort)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import System.IO+import System.IO.Error (tryIOError)+import System.IO.Unsafe (unsafePerformIO)+import System.Directory++import GhcPlugins ( CommandLineOption+ , Hsc+ , HsParsedModule (..)+ , ModSummary+ , Plugin (..)+ , liftIO+ , purePlugin+ )+import GhcPlugins hiding (occName, (<>))+import HsExtension (GhcPs)+import HsSyn (HsModule)++import Plugin.GhcTags.Generate+import Plugin.GhcTags.Parser+import Plugin.GhcTags.Vim+++-- | Global shared state which persists across compilation of different+-- modules - a nasty hack which is only used for optimzation.+--+tagsMVar :: MVar (Maybe TagsMap)+tagsMVar = unsafePerformIO $ newMVar Nothing++-- | The GhcTags plugin. It will run for every compiled module and have access+-- to parsed syntax tree. It will inpect it and:+--+-- * update a global mutable state variable, which stores a tag map.+-- It is shared accross modules compiled in the same `ghc` run.+-- * update 'tags' file.+--+-- The global mutable variable save us from parsing the tags file for every+-- compiled module.+--+-- __The syntax tree is left unchanged.__+-- +-- The tags file will contain location information about:+--+-- * top level terms+-- * data types+-- * record fields+-- * type synonyms+-- * type classes+-- * type class members+-- * type class instances+-- * type families /(standalone and associated)/+-- * type family instances /(standalone and associated)/+-- * data type families /(standalone and associated)/+-- * data type families instances /(standalone and associated)/+-- * data type family instances constructors /(standalone and associated)/+--+plugin :: Plugin+plugin = GhcPlugins.defaultPlugin {+ parsedResultAction = ghcTagPlugin,+ pluginRecompile = purePlugin+ }+++-- | The plugin does not change the 'HsParedModule', it only runs side effects.+--+ghcTagPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule+ghcTagPlugin options _modSummary hsParsedModule@HsParsedModule {hpm_module} =+ hsParsedModule <$ liftIO (updateTags tagsFile hpm_module)+ where+ tagsFile :: FilePath+ tagsFile = case options of+ [] -> "tags"+ a : _ -> a+++-- | Extract tags from a module and update tags file as well as the 'tagsMVar'+-- Using 'tagsMVar' we can save on parsing the tags file: we do it only when+-- the first module is compiled. We need to write the results at every+-- compilation step since we don't know if the currently compiled module is the+-- last one or not.+--+updateTags :: FilePath+ -> Located (HsModule GhcPs)+ -> IO ()+updateTags tagsFile lmodule =+ -- Take exclusive lock. This assures that only one thread will have access to+ -- the tags file. Parsing and the rest of the compilation pipeline can+ -- happen concurrently.+ mvarLock tagsMVar $ \mTagsMap -> do+ (tagsMap :: TagsMap) <-+ case mTagsMap of++ Just tagsMap -> return tagsMap++ -- the 'tagsMVar' is empty, which means we are compiling the first+ -- module. In this case read the tags from disk.+ Nothing -> do+ a <- doesFileExist tagsFile+ res <-+ if a+ then do+ mbytes <- tryIOError (BS.readFile tagsFile)+ case mbytes of+ Left err -> do+ putStrLn $ "GhcTags: error reading \"" ++ tagsFile ++ "\": " ++ (show err)+ pure $ Right []+ Right bytes ->+ parseVimTagFile bytes+ else pure $ Right []+ case res of+ Left err -> do+ putStrLn $ "GhcTags: error reading or parsing \"" ++ tagsFile ++ "\": " ++ err+ return $ Map.empty+ Right tagList -> do+ return $ mkTagsMap tagList++ let tagsMap' :: TagsMap+ tagsMap' =+ (mkTagsMap -- created 'TagsMap'+ . mapMaybe ghcTagToTag -- tranalte 'GhcTag' to 'Tag'+ . getGhcTags -- generate 'GhcTag's+ $ lmodule)+ `Map.union`+ tagsMap++ -- update tags file, this will force evaluation `tagsMap'`, so when we+ -- write it to `tagsMVar' it will not contain any thunks.+ withFile tagsFile WriteMode+ $ flip BS.hPutBuilder+ ( formatVimTagFile+ . sort+ . concat+ . Map.elems+ $ tagsMap'+ )++ pure (Just tagsMap')+++-- | The 'MVar' is used as an exlusive lock. Also similar to 'bracket' but+-- updates the 'MVar' with returned value, or put the original value if an+-- exception is thrown by the continuation (or an async exception).+--+mvarLock :: MVar a+ -> (a -> IO a)+ -> IO ()+mvarLock v k = mask $ \unmask -> do+ a <- takeMVar v+ a' <- unmask (k a)+ `onException`+ putMVar v a+ putMVar v $! a'