diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +# hs-tags + +Version history. + +## 0.1.5 released 2021-03-16 + +- initial release +- tested with GHC 8.0.2 - 9.0.1 + +## Prehistory + +- originally written in Dec 2007 by Ulf Norell to generate ctags via GHC 6.8 +- extended in Feb 2008 by Nils Anders Danielsson to etags +- since then, used in the Agda development process and updated to new GHC versions diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2009-2021 Ulf Norell, Nils Anders Danielsson, + Andrés Sicard-Ramírez, Andreas Abel, Francesco Mazzoli, Paolo G. Giarrusso + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Arrow ((&&&)) +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Data.Char +import qualified Data.Traversable as T +import Data.List +import Data.Maybe +import Data.Version ( showVersion ) +import System.Environment +import System.IO +import qualified System.IO.Strict as Strict +import System.Exit +import System.FilePath +import System.Directory +import System.Process +import System.Console.GetOpt + +import GHC + ( DynFlags + , HsModule + , Located + , RealSrcLoc + , includePaths + , getSession + , getSessionDynFlags + , setSessionDynFlags + , runGhc + ) +#if MIN_VERSION_ghc(8,4,0) +import GHC (GhcPs) +#else +import GHC (RdrName) +#endif + +-- In ghc-9.0, hierarchical modules were introduced, +-- so most modules got renamed. +#if MIN_VERSION_ghc(9,0,0) + +import GHC.Data.FastString ( mkFastString ) +import GHC.Data.StringBuffer ( hGetStringBuffer ) +import GHC.Driver.Monad ( GhcT(..), Ghc(..) ) +import GHC.Driver.Phases ( pattern Cpp, pattern HsSrcFile ) +import GHC.Driver.Pipeline ( preprocess ) +import GHC.Driver.Session ( pattern IncludeSpecs, opt_P, parseDynamicFilePragma, sOpt_P, toolSettings ) +import GHC.Parser ( parseModule ) +import GHC.Parser.Lexer ( P(..), ParseResult(..), PState, mkPState, getErrorMessages ) +import GHC.Settings ( toolSettings_opt_P ) +import GHC.Types.SrcLoc ( mkRealSrcLoc, noLoc, unLoc ) + +-- THESE MODULES cannot be imported, it seems: +-- import GHC.Driver.Errors ( printBagOfErrors ) +-- import GHC.Types.SourceError (throwErrors) +-- import GHC.Parser.Errors.Ppr (pprError) +-- import GHC.Utils.Error.ErrorMessages + +#else + +import DriverPhases ( pattern Cpp, pattern HsSrcFile ) +import DriverPipeline ( preprocess ) +import DynFlags ( opt_P, sOpt_P, settings, parseDynamicFilePragma ) +import FastString ( mkFastString ) +import GhcMonad ( GhcT(..), Ghc(..) ) +import Lexer ( P(..), ParseResult(..), PState, mkPState ) +import Parser ( parseModule ) +import SrcLoc ( mkRealSrcLoc, noLoc, unLoc ) +import StringBuffer ( hGetStringBuffer ) + +#if MIN_VERSION_ghc(8,6,1) +import DynFlags ( pattern IncludeSpecs ) +#endif + +#if MIN_VERSION_ghc(8,10,1) +import GHC ( toolSettings ) +import ToolSettings ( toolSettings_opt_P ) +import Lexer ( getErrorMessages ) +import ErrUtils ( printBagOfErrors ) +#else +import ErrUtils ( mkPlainErrMsg ) +#endif + +#endif + +import Language.Haskell.Extension as LHE +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription hiding (options) +#if MIN_VERSION_Cabal(2,2,0) +import qualified Distribution.PackageDescription.Parsec as PkgDescParse +import Distribution.PackageDescription.Parsec hiding (ParseResult) +#else +import qualified Distribution.PackageDescription.Parse as PkgDescParse +import Distribution.PackageDescription.Parse hiding (ParseResult) +#endif + +import Tags +import Paths_hs_tags ( version ) + +instance MonadTrans GhcT where + lift m = GhcT $ const m + +fileLoc :: FilePath -> RealSrcLoc +fileLoc file = mkRealSrcLoc (mkFastString file) 1 0 + +filePState :: DynFlags -> FilePath -> IO PState +filePState dflags file = do + buf <- hGetStringBuffer file + return $ + mkPState dflags buf (fileLoc file) + + +#if MIN_VERSION_ghc(9,0,0) +pMod :: P (Located HsModule) +#elif MIN_VERSION_ghc(8,4,0) +pMod :: P (Located (HsModule GhcPs)) +#else +pMod :: P (Located (HsModule RdrName)) +#endif +pMod = parseModule + +parse :: PState -> P a -> ParseResult a +parse st p = unP p st + +goFile :: FilePath -> Ghc [Tag] +goFile file = do + liftIO $ hPutStrLn stderr $ "Processing " ++ file + env <- getSession +#if MIN_VERSION_ghc(8,8,1) + r <- liftIO $ + preprocess env file Nothing (Just $ Cpp HsSrcFile) + let (dflags, srcFile) = case r of + Left _ -> error $ "preprocessing " ++ file + Right x -> x +#else + (dflags, srcFile) <- liftIO $ + preprocess env (file, Just $ Cpp HsSrcFile) +#endif + st <- liftIO $ filePState dflags srcFile + case parse st pMod of + POk _ m -> return $ removeDuplicates $ tags $ unLoc m +#if MIN_VERSION_ghc(9,0,0) + PFailed pState -> liftIO $ do + -- Andreas, 2021-03-03, how can we print the errors with ghc-9.0? + -- @printBagOfErrors@ does not seem to be exported, + -- neither @pprError@... + -- throwErrors $ fmap pprError $ getErrorMessages pState dflags + hPutStrLn stderr "PARSE ERROR" +#elif MIN_VERSION_ghc(8,10,1) + PFailed pState -> liftIO $ do + printBagOfErrors dflags $ getErrorMessages pState dflags +#elif MIN_VERSION_ghc(8,4,0) + PFailed _ loc err -> liftIO $ do + print (mkPlainErrMsg dflags loc err) +#else + PFailed loc err -> liftIO $ do + print (mkPlainErrMsg dflags loc err) +#endif + exitWith $ ExitFailure 1 + +runCmd :: String -> IO String +runCmd cmd = do + (_, h, _, _) <- runInteractiveCommand cmd + hGetContents h + +-- XXX This is a quick hack; it will certainly work if the language description +-- is not conditional. Otherwise we'll need to figure out both the flags and the +-- build configuration to call `finalizePackageDescriptionSource`. +configurePackageDescription :: + GenericPackageDescription -> PackageDescription +configurePackageDescription = flattenPackageDescription + +extractLangSettings :: + GenericPackageDescription + -> ([Extension], Maybe LHE.Language) +extractLangSettings gpd = + maybe ([], Nothing) + ((defaultExtensions &&& defaultLanguage) . libBuildInfo) + ((library . configurePackageDescription) gpd) + +extToOpt :: Extension -> String +extToOpt (UnknownExtension e) = "-X" ++ e +extToOpt (EnableExtension e) = "-X" ++ show e +extToOpt (DisableExtension e) = "-XNo" ++ show e + +langToOpt :: LHE.Language -> String +langToOpt l = "-X" ++ show l + +cabalConfToOpts :: GenericPackageDescription -> [String] +cabalConfToOpts desc = langOpts ++ extOpts + where + (exts, maybeLang) = extractLangSettings desc + extOpts = map extToOpt exts + langOpts = langToOpt <$> maybeToList maybeLang + +main :: IO () +main = do + opts <- getOptions + + let agdaReadPackageDescription = +#if MIN_VERSION_Cabal(2,0,0) + readGenericPackageDescription +#else + readPackageDescription +#endif + + pkgDesc <- T.mapM (agdaReadPackageDescription minBound) $ optCabalPath opts + let go | optHelp opts = do + printUsage stdout + exitSuccess + | otherwise = do + top : _ <- lines <$> runCmd "ghc --print-libdir" + ts <- runGhc (Just top) $ do + dynFlags <- getSessionDynFlags + let dynFlags' = + dynFlags { +#if MIN_VERSION_ghc(8,10,1) + toolSettings = (toolSettings dynFlags) { + toolSettings_opt_P = concatMap (\i -> [i, "-include"]) (optIncludes opts) ++ + opt_P dynFlags + } +#else + settings = (settings dynFlags) { + sOpt_P = concatMap (\i -> [i, "-include"]) (optIncludes opts) ++ + opt_P dynFlags + } +#endif + +#if MIN_VERSION_ghc(8,6,1) + , includePaths = case includePaths dynFlags of + IncludeSpecs qs gs -> IncludeSpecs qs (optIncludePath opts ++ gs) +#else + , includePaths = optIncludePath opts ++ includePaths dynFlags +#endif + } + (dynFlags'', _, _) <- parseDynamicFilePragma dynFlags' $ map noLoc $ concatMap cabalConfToOpts (maybeToList pkgDesc) + setSessionDynFlags dynFlags'' + mapM (\f -> liftM2 ((,,) f) (liftIO $ Strict.readFile f) + (goFile f)) $ + optFiles opts + when (optCTags opts) $ + let sts = sort $ concatMap (\(_, _, t) -> t) ts in + writeFile (optCTagsFile opts) $ unlines $ map show sts + when (optETags opts) $ + writeFile (optETagsFile opts) $ showETags ts + go + +getOptions :: IO Options +getOptions = do + args <- getArgs + case getOpt Permute options args of + ([], [], []) -> do + printUsage stdout + exitSuccess + (opts, files, []) -> return $ foldr ($) (defaultOptions files) opts + (_, _, errs) -> do + hPutStr stderr $ unlines errs + printUsage stderr + exitWith $ ExitFailure 1 + +printUsage h = do + prog <- getProgName + let header = unwords [ prog, "version", showVersion version ] + hPutStrLn h $ usageInfo header options + +data Options = Options + { optCTags :: Bool + , optETags :: Bool + , optCTagsFile :: String + , optETagsFile :: String + , optHelp :: Bool + , optIncludes :: [FilePath] + , optFiles :: [FilePath] + , optIncludePath :: [FilePath] + , optCabalPath :: Maybe FilePath + } + +defaultOptions :: [FilePath] -> Options +defaultOptions files = Options + { optCTags = False + , optETags = False + , optCTagsFile = "tags" + , optETagsFile = "TAGS" + , optHelp = False + , optIncludes = [] + , optFiles = files + , optIncludePath = [] + , optCabalPath = Nothing + } + +options :: [OptDescr (Options -> Options)] +options = + [ Option [] ["help"] (NoArg setHelp) "Show help." + , Option ['c'] ["ctags"] (OptArg setCTagsFile "FILE") "Generate ctags (default file=tags)" + , Option ['e'] ["etags"] (OptArg setETagsFile "FILE") "Generate etags (default file=TAGS)" + , Option ['i'] ["include"] (ReqArg addInclude "FILE") "File to #include" + , Option ['I'] [] (ReqArg addIncludePath "DIRECTORY") "Directory in the include path" + , Option [] ["cabal"] (ReqArg addCabal "CABAL FILE") "Cabal configuration to load additional language options from (library options are used)" + ] + where + setHelp o = o { optHelp = True } + setCTags o = o { optCTags = True } + setETags o = o { optETags = True } + setCTagsFile file o = o { optCTagsFile = fromMaybe "tags" file, optCTags = True } + setETagsFile file o = o { optETagsFile = fromMaybe "TAGS" file, optETags = True } + addInclude file o = o { optIncludes = file : optIncludes o } + addIncludePath dir o = o { optIncludePath = dir : optIncludePath o} + addCabal file o = o { optCabalPath = Just file } diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,49 @@ +hs-tags - Generate tags for Haskell code +======================================== + +Generate `tags` (ctags) or `TAGS` (etags) file for a bunch of Haskell files. +These files are used by editors (e.g. `TAGS` by Emacs) to implement _jump-to-definition_ (e.g. `M-.` in Emacs). + +In contrast to [hasktags](http://hackage.haskell.org/package/hasktags), `hs-tags` uses the GHC Haskell parser to read the Haskell files and find definition sites. + +Example use: +``` +find src -name "*.*hs" | xargs \ + hs-tags --cabal Foo.cabal -i dist/build/autogen/cabal_macros.h -e +``` +Creates Emacs `TAGS` from Haskell files residing in folder `src/` of the project as defined in `Foo.cabal`, using preprocessor definitions from `dist/build/autogen/cabal_macros.h`. + +Command line reference: +``` +hs-tags + --help Show help. + -c[FILE] --ctags[=FILE] Generate ctags (default file=tags) + -e[FILE] --etags[=FILE] Generate etags (default file=TAGS) + -i FILE --include=FILE File to #include + -I DIRECTORY Directory in the include path + --cabal=CABAL FILE Cabal configuration to load additional + language options from + (library options are used) +``` + +Some related projects: + +- [hasktags](http://hackage.haskell.org/package/hasktags): + popular ctags and etags generator, using its own parser. + +- [fast-tags](https://hackage.haskell.org/package/fast-tags): + ctags and etags, fast, incremental, using its own parser. + +- [ghc-tags-plugin](https://hackage.haskell.org/package/ghc-tags-plugin): + ctags and etags emitted during compilation by a ghc-plugin. + +- [hothasktags](https://hackage.haskell.org/package/hothasktags) + (_unmaintained_?): + ctags generator, using the [haskell-src-exts](https://hackage.haskell.org/package/haskell-src-exts) parser. + +- [htags](https://hackage.haskell.org/package/htags): + ctags for Haskell 98, using the [haskell-src](https://hackage.haskell.org/package/haskell-src) parser. + +- [codex](https://hackage.haskell.org/package/codex): + ctags and etags for dependencies, using + [hasktags](http://hackage.haskell.org/package/hasktags). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/Tags.hs b/Tags.hs new file mode 100644 --- /dev/null +++ b/Tags.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE UndecidableInstances #-} + +module Tags where + +import Data.Function +import Data.List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map + +#if MIN_VERSION_ghc(8,10,1) +import GHC.Hs +#else +import HsSyn +#endif + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Types.SrcLoc +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence +import qualified GHC.Types.Name as Name +import GHC.Data.FastString +import GHC.Data.Bag +import qualified GHC.Types.Basic as BasicTypes +#else +import SrcLoc +import RdrName +import OccName +import qualified Name +import FastString +import Bag +import qualified BasicTypes +#endif + + +data Pos = Pos { line, column :: Int } + deriving (Eq, Ord) + +data Tag = NoLoc String + | Tag String FilePath Pos + deriving (Eq, Ord) + +-- | Removes duplicate /adjacent/ tags, ignoring the 'Pos' field. + +removeDuplicates :: [Tag] -> [Tag] +removeDuplicates = map head . groupBy ((==) `on` everythingButPos) + where + dummyPos = Pos 0 0 + + everythingButPos (Tag s f p) = Tag s f dummyPos + everythingButPos t@NoLoc {} = t + +-- | Takes a list of (filename, file contents, tags) and generates +-- text for an etags file. + +-- I found the etags file format on Wikipedia; I have not found an +-- authoritative definition of it. +-- +-- For every file containing tags a section is generated. +-- Section header (two lines): +-- \x0c +-- , +-- This is followed by one line for every tag: +-- \x7f +-- \x01 +-- , + +showETags :: [(FilePath, String, [Tag])] -> String +showETags = concatMap showFile + where + showFile (f, contents, ts) = + unlines ["\x0c", f ++ "," ++ show bytes] ++ ts' + where + ts' = unlines $ mapMaybe showTag ts + + -- TODO: This should be the length in _bytes_ of ts'. However, + -- since the rest of this program seems to assume an 8-bit + -- character encoding I just count the number of characters. + bytes = length ts' + + lineMap = Map.fromList $ zip [1..] (lines contents) + + showTag (NoLoc _) = Nothing + showTag (Tag t f p) = Just $ + take' (column p) (lineMap ! line p) ++ t ++ "\x7f" ++ + t ++ "\x01" ++ + show (line p) ++ ",0" + -- I don't know what the last offset is used for, so I have set + -- it to 0. This seems to work. + + take' = tabAwareTake 0 + m ! k = Map.findWithDefault (error $ "Cannot find line " ++ show k ++ " in lineMap") k m + + -- A variant of take which is aware of tab characters. Uses tab + -- size 8, and only recognises the ordinary ASCII horizontal tab + -- ('\t'). The first argument is the position of the first + -- character. Tabs are only expanded into spaces if necessary. + tabAwareTake pos n s | n <= 0 = "" + tabAwareTake pos n "" = "" + tabAwareTake pos n (c : s) + | c /= '\t' = c : tabAwareTake (pos + 1) (n - 1) s + | stepSize > n = replicate n ' ' + | otherwise = c : tabAwareTake nextTabStop (n - stepSize) s + where + tabSize = 8 + nextTabStop = (pos `div` tabSize + 1) * tabSize + stepSize = nextTabStop - pos + +instance Show Tag where + show (Tag t f p) = intercalate "\t" [t, f, show (line p)] + show (NoLoc t) = unwords [t, ".", "0"] + +srcLocTag :: SrcLoc -> Tag -> Tag +srcLocTag UnhelpfulLoc{} t = t +#if MIN_VERSION_ghc(9,0,0) +srcLocTag (RealSrcLoc l _) (NoLoc t) = +#else +srcLocTag (RealSrcLoc l) (NoLoc t) = +#endif + Tag t + (unpackFS $ srcLocFile l) + Pos { line = srcLocLine l + -- GHC 7 counts columns starting from 1. + , column = srcLocCol l - 1 + } +srcLocTag _ t@Tag{} = t + +class TagName a where + tagName :: a -> String + +instance TagName RdrName where + tagName x = case x of + Unqual x -> tagName x + Qual _ x -> tagName x + Orig _ x -> tagName x + Exact x -> tagName x + +instance TagName OccName where + tagName = unpackFS . occNameFS + +instance TagName Name.Name where + tagName = tagName . Name.nameOccName + +#if MIN_VERSION_ghc(8,4,0) +instance (IdP pass ~ name, TagName name) => TagName (FieldOcc pass) where +#else +instance TagName a => TagName (FieldOcc a) where +#endif +#if MIN_VERSION_ghc(8,6,1) + tagName (FieldOcc _ (L _ rdrName)) = tagName rdrName + tagName (XFieldOcc _) = missingImp "XFieldOcc" +#else + tagName (FieldOcc (L _ rdrName) _) = tagName rdrName +#endif + +class HasTags a where + tags :: a -> [Tag] + +instance HasTags Tag where + tags x = [x] + +instance HasTags a => HasTags [a] where + tags = concatMap tags + +instance (HasTags a, HasTags b) => HasTags (a, b) where + tags (x, y) = tags x ++ tags y + +instance HasTags a => HasTags (Maybe a) where + tags = maybe [] tags + +instance HasTags a => HasTags (Bag a) where + tags = tags . bagToList + +instance HasTags a => HasTags (Located a) where + tags (L l x) = map (srcLocTag $ srcSpanStart l) $ tags x + +newtype Name a = Name a + +instance TagName name => HasTags (Name name) where + tags (Name x) = [NoLoc $ tagName x] + +tagsLN :: TagName name => Located name -> [Tag] +tagsLN = tags . fmap Name + +tagsN :: TagName name => name -> [Tag] +tagsN = tags . Name + +#if MIN_VERSION_ghc(9,0,0) +instance HasTags HsModule where +#else +#if MIN_VERSION_ghc(8,4,0) +instance ( IdP pass ~ name + , TagName name +#if MIN_VERSION_ghc(8,10,1) + , HasTags (XRec pass Pat) +#endif + ) => HasTags (HsModule pass) where +#else +instance TagName name => HasTags (HsModule name) where +#endif +#endif + tags HsModule{ hsmodExports = export + , hsmodDecls = decls + } = tags decls -- TODO: filter exports + +#if MIN_VERSION_ghc(8,4,0) +instance ( IdP pass ~ name + , TagName name +#if MIN_VERSION_ghc(8,10,1) + , HasTags (XRec pass Pat) +#endif + ) => HasTags (HsDecl pass) where +#else +instance TagName name => HasTags (HsDecl name) where +#endif + tags d = case d of +#if MIN_VERSION_ghc(8,10,1) + KindSigD _ d -> tags d +#endif +#if MIN_VERSION_ghc(8,6,1) + TyClD _ d -> tags d + ValD _ d -> tags d + SigD _ d -> tags d + ForD _ d -> tags d + XHsDecl _ -> missingImp "XHsDecl" +#else + TyClD d -> tags d + ValD d -> tags d + SigD d -> tags d + ForD d -> tags d +#endif + DocD{} -> [] + SpliceD{} -> [] + RuleD{} -> [] + DefD{} -> [] + InstD{} -> [] + DerivD{} -> [] + WarningD{} -> [] + AnnD{} -> [] + RoleAnnotD{} -> [] +#if !MIN_VERSION_ghc(8,6,1) + VectD{} -> [] +#endif + +#if MIN_VERSION_ghc(8,4,0) +instance (IdP pass ~ name, TagName name) => HasTags (FamilyDecl pass) where +#else +instance TagName name => HasTags (FamilyDecl name) where +#endif + tags d = tagsLN (fdLName d) + +instance HasTags (BasicTypes.Origin) where + tags _ = [] + +#if MIN_VERSION_ghc(8,4,0) +instance (IdP pass ~ name, TagName name) => HasTags (TyClDecl pass) where +#else +instance TagName name => HasTags (TyClDecl name) where +#endif +#if MIN_VERSION_ghc(8,6,1) + tags (FamDecl _ d) = tags d +#else + tags (FamDecl d) = tags d +#endif + tags d = tagsLN (tcdLName d) ++ + case d of + DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cons } } + -> tags cons + ClassDecl { tcdSigs = meths + , tcdATs = ats + } -> tags (meths, ats) + _ -> [] + +#if MIN_VERSION_ghc(8,4,0) +instance (IdP pass ~ name, TagName name) => HasTags (ConDecl pass) where +#else +instance TagName name => HasTags (ConDecl name) where +#endif +#if MIN_VERSION_ghc(8,6,1) + tags (ConDeclGADT _ cns _ _ _ _ _ _) = concatMap tagsLN cns + tags (ConDeclH98 _ cn _ _ _ cd _) = tagsLN cn ++ tags cd + tags (XConDecl _) = missingImp "XConDecl" +#else + tags (ConDeclGADT cns _ _) = concatMap tagsLN cns + tags (ConDeclH98 cn _ _ cd _) = tagsLN cn ++ tags cd +#endif + +#if MIN_VERSION_ghc(8,4,0) +instance (IdP pass ~ name, TagName name) => HasTags (ConDeclField pass) where +#else +instance TagName name => HasTags (ConDeclField name) where +#endif +#if MIN_VERSION_ghc(8,6,1) + tags (ConDeclField _ x _ _) = concatMap tagsLN x + tags (XConDeclField _) = missingImp "XConDeclField" +#else + tags (ConDeclField x _ _) = concatMap tagsLN x +#endif + +-- Dummy instance. +instance HasTags (HsType name) where + tags _ = [] + +#if MIN_VERSION_ghc(8,4,0) +instance ( IdP pass ~ name + , TagName name +#if MIN_VERSION_ghc(8,10,1) + , HasTags (XRec pass Pat) +#endif + ) => HasTags (HsBind pass) where +#else +instance TagName name => HasTags (HsBind name) where +#endif + tags d = case d of + FunBind { fun_id = x } -> tagsLN x + PatBind { pat_lhs = lhs } -> tags lhs + VarBind { var_id = x } -> tagsN x + AbsBinds { abs_binds = bs } -> tags bs +#if !MIN_VERSION_ghc(8,4,1) + AbsBindsSig { abs_sig_bind = bs } -> tags bs +#endif +#if MIN_VERSION_ghc(8,6,1) + PatSynBind _ (PSB { psb_id = x }) -> tagsLN x + PatSynBind _ XPatSynBind{} -> missingImp "XPatSynBindPSB" + XHsBindsLR{} -> missingImp "XHsBindsLR" +#else + PatSynBind (PSB { psb_id = x }) -> tagsLN x +#endif + + +#if MIN_VERSION_ghc(8,4,0) +instance ( IdP pass ~ name + , TagName name +#if MIN_VERSION_ghc(8,10,1) + , HasTags (XRec pass Pat) +#endif + ) => HasTags (Pat pass) where +#else +instance TagName name => HasTags (Pat name) where +#endif + tags p = case p of +#if MIN_VERSION_ghc(8,6,1) + VarPat _ x -> tagsLN x +#else + VarPat x -> tagsLN x +#endif +#if MIN_VERSION_ghc(8,8,1) + SigPat _ p _ -> tags p +#elif MIN_VERSION_ghc(8,6,1) + SigPat _ p -> tags p +#endif +#if MIN_VERSION_ghc(8,6,1) + LazyPat _ p -> tags p + AsPat _ x p -> tags (fmap Name x, p) + ParPat _ p -> tags p + BangPat _ p -> tags p + ListPat _ ps -> tags ps + TuplePat _ ps _ -> tags ps + XPat _ -> missingImp "XPat" +#else + LazyPat p -> tags p + AsPat x p -> tags (fmap Name x, p) + ParPat p -> tags p + BangPat p -> tags p + ListPat ps _ _ -> tags ps + TuplePat ps _ _ -> tags ps + SigPatIn p _ -> tags p + SigPatOut p _ -> tags p + PArrPat ps _ -> tags ps +#endif +#if MIN_VERSION_ghc(9,0,0) + ConPat { pat_args = ps } -> tags ps +#else + ConPatIn _ ps -> tags ps + ConPatOut{ pat_args = ps } -> tags ps + CoPat{} -> [] +#endif +#if MIN_VERSION_ghc(8,6,1) + NPlusKPat _ x _ _ _ _ -> tagsLN x +#else + NPlusKPat x _ _ _ _ _ -> tagsLN x +#endif + NPat{} -> [] + LitPat{} -> [] + WildPat{} -> [] + ViewPat{} -> [] + SplicePat{} -> [] +#if MIN_VERSION_ghc(8,2,0) + SumPat{} -> missingImp "SumPat" +#endif + +#if MIN_VERSION_ghc(9,0,0) +instance HasTags arg => HasTags (HsScaled pass arg) where + tags = tags . hsScaledThing +#endif + +instance (HasTags arg, HasTags recc) => HasTags (HsConDetails arg recc) where + tags d = case d of + PrefixCon as -> tags as + RecCon r -> tags r + InfixCon a1 a2 -> tags [a1, a2] + +instance HasTags arg => HasTags (HsRecFields name arg) where + tags (HsRecFields fs _) = tags fs + +instance HasTags arg => HasTags (HsRecField name arg) where + tags (HsRecField _ a _) = tags a + +#if MIN_VERSION_ghc(8,4,0) +instance (IdP pass ~ name, TagName name) => HasTags (Sig pass) where +#else +instance TagName name => HasTags (Sig name) where +#endif + tags d = case d of +#if MIN_VERSION_ghc(8,6,1) + TypeSig _ x _ -> concatMap tagsLN x +#else + TypeSig x _ -> concatMap tagsLN x +#endif +#if MIN_VERSION_ghc(8,6,1) + PatSynSig _ x _ -> concatMap tagsLN x +#elif MIN_VERSION_ghc(8,2,0) + PatSynSig x _ -> concatMap tagsLN x +#else + PatSynSig x _ -> tagsLN x +#endif +#if MIN_VERSION_ghc(8,6,1) + ClassOpSig _ _ x _ -> concatMap tagsLN x +#else + ClassOpSig _ x _ -> concatMap tagsLN x +#endif + FixSig{} -> [] + InlineSig{} -> [] + SpecSig{} -> [] + SpecInstSig{} -> [] + IdSig{} -> [] + MinimalSig{} -> [] +#if MIN_VERSION_ghc(8,2,0) + SCCFunSig{} -> [] + CompleteMatchSig{} -> [] +#endif +#if MIN_VERSION_ghc(8,6,1) + XSig{} -> missingImp "XSig" +#endif + +#if MIN_VERSION_ghc(8,4,0) +instance (IdP pass ~ name, TagName name) => HasTags (ForeignDecl pass) where +#else +instance TagName name => HasTags (ForeignDecl name) where +#endif + tags d = case d of +#if MIN_VERSION_ghc(8,6,1) + ForeignImport _ x _ _ -> tagsLN x + XForeignDecl _ -> missingImp "XForeignDecl" +#else + ForeignImport x _ _ _ -> tagsLN x +#endif + ForeignExport{} -> [] + +#if MIN_VERSION_ghc(8,10,1) +instance (IdP pass ~ name, TagName name) => HasTags (StandaloneKindSig pass) where + tags d = case d of + StandaloneKindSig _ x _ -> tagsLN x + XStandaloneKindSig _ -> missingImp "XStandaloneKindSig" +#endif + +missingImp :: String -> a +missingImp x = error $ "Missing implementation: " ++ x diff --git a/hs-tags.cabal b/hs-tags.cabal new file mode 100644 --- /dev/null +++ b/hs-tags.cabal @@ -0,0 +1,59 @@ +name: hs-tags +version: 0.1.5 +cabal-version: >= 1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: (c) 2005-2021 The Agda Team. +author: Ulf Norell, Nils Anders Danielsson, Andrés Sicard-Ramírez, Andreas Abel, Francesco Mazzoli, Paolo G. Giarrusso +maintainer: Andreas Abel +bug-reports: https://github.com/agda/hs-tags/issues +category: Development +synopsis: Create tag files (ctags and etags) for Haskell code. +description: . + Executable to generate a tags (ctags) or TAGS (etags) file + for a bunch of Haskell files. + These files are used by editors (e.g. TAGS by Emacs) to + implement jump-to-definition (e.g. M-. in Emacs). + +tested-with: + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/agda/hs-tags.git + +source-repository this + type: git + location: https://github.com/agda/hs-tags.git + tag: v0.1.5 + +executable hs-tags + main-is: Main.hs + other-modules: Tags + Paths_hs_tags + + default-language: Haskell2010 + + build-depends: + base >= 4.9.0.0 && < 4.16 + , Cabal >= 1.24.0.0 && < 3.5 + , containers >= 0.5.7.1 && < 0.7 + , directory >= 1.2.6.2 && < 1.4 + , filepath >= 1.4.1.0 && < 1.5 + , ghc >= 8.0.2 && < 9.1 + , mtl >= 2.2.1 && < 2.3 + , process >= 1.4.2.0 && < 1.7 + , strict >= 0.3.2 && < 0.5 + + ghc-options: -fwarn-incomplete-patterns