diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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.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 diff --git a/lib/Plugin/GhcTags.hs b/lib/Plugin/GhcTags.hs deleted file mode 100644 --- a/lib/Plugin/GhcTags.hs +++ /dev/null @@ -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' diff --git a/lib/Plugin/GhcTags/Generate.hs b/lib/Plugin/GhcTags/Generate.hs --- a/lib/Plugin/GhcTags/Generate.hs +++ b/lib/Plugin/GhcTags/Generate.hs @@ -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 diff --git a/lib/Plugin/GhcTags/Parser.hs b/lib/Plugin/GhcTags/Parser.hs --- a/lib/Plugin/GhcTags/Parser.hs +++ b/lib/Plugin/GhcTags/Parser.hs @@ -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 -- diff --git a/lib/Plugin/GhcTags/Vim.hs b/lib/Plugin/GhcTags/Vim.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/Vim.hs @@ -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 diff --git a/src/Plugin/GhcTags.hs b/src/Plugin/GhcTags.hs new file mode 100644 --- /dev/null +++ b/src/Plugin/GhcTags.hs @@ -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'