Commit 027017fb authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot
Browse files

Remove ghctags (#16274)

parent 53a870f4
Pipeline #2029 passed with stages
in 221 minutes and 54 seconds
......@@ -482,9 +482,6 @@ endif
ifneq "$(BINDIST)" "YES"
compiler_stage2_TAGS_HC_OPTS = -package ghc
$(eval $(call tags-package,compiler,stage2))
$(compiler_stage1_depfile_haskell) : compiler/stage1/$(PLATFORM_H)
$(compiler_stage2_depfile_haskell) : compiler/stage2/$(PLATFORM_H)
$(compiler_stage3_depfile_haskell) : compiler/stage3/$(PLATFORM_H)
......
......@@ -340,7 +340,6 @@ include rules/build-perl.mk
include rules/build-package.mk
include rules/build-package-way.mk
include rules/haddock.mk
include rules/tags-package.mk
include rules/foreachLibrary.mk
# -----------------------------------------------------------------------------
......@@ -553,7 +552,6 @@ ghc/stage2/package-data.mk: compiler/stage2/package-data.mk
# the ghc library's package-data.mk is sufficient, as that in turn depends on
# all the other libraries' package-data.mk files.
utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk
utils/ghctags/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/check-api-annotations/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/check-ppr/dist-install/package-data.mk: compiler/stage2/package-data.mk
......@@ -666,7 +664,6 @@ BUILD_DIRS += compiler
BUILD_DIRS += utils/hsc2hs
BUILD_DIRS += utils/ghc-pkg
BUILD_DIRS += utils/testremove
BUILD_DIRS += utils/ghctags
BUILD_DIRS += utils/check-api-annotations
BUILD_DIRS += utils/check-ppr
BUILD_DIRS += utils/ghc-cabal
......@@ -716,7 +713,6 @@ endif
ifneq "$(CrossCompiling) $(Stage1Only)" "NO NO"
# See Note [No stage2 packages when CrossCompiling or Stage1Only].
# See Note [Stage1Only vs stage=1] in mk/config.mk.in.
BUILD_DIRS := $(filter-out utils/ghctags,$(BUILD_DIRS))
BUILD_DIRS := $(filter-out utils/check-api-annotations,$(BUILD_DIRS))
BUILD_DIRS := $(filter-out utils/check-ppr,$(BUILD_DIRS))
endif
......@@ -845,12 +841,6 @@ libraries/ghc-prim/dist-install/build/autogen/GHC/Prim.hs: \
| $$(dir $$@)/.
"$(genprimopcode_INPLACE)" --make-haskell-source < $< > $@
.PHONY: tags
tags: tags_compiler
.PHONY: TAGS
TAGS: TAGS_compiler
# -----------------------------------------------------------------------------
# Installation
......@@ -1512,8 +1502,8 @@ endif
# - neither do we register the ghc library (compiler/stage1) that we build
# with stage0. TODO Why not? We do build it...
# - as a result, we need to a) use ghc-stage2 to build packages that depend on
# the ghc library (e.g. ghctags [4]) and b) exclude those packages when
# ghc-stage2 is not available.
# the ghc library and b) exclude those packages when ghc-stage2 is not
# available.
# - when Stage1Only=YES, it's clear that ghc-stage2 is not available (we just
# said we didn't want it), so we have to exclude the stage2 packages from
# the build. This includes the case where Stage1Only=YES is combined with
......@@ -1521,7 +1511,7 @@ endif
# - when CrossCompiling=YES, but Stage1Only=NO (Cross-compiling GHC itself
# [3]), we can not use ghc-stage2 either. The reason is that stage2 doesn't
# run on the host platform at all; it is built to run on $(TARGETPLATFORM)"
# [5]. Therefore in this case we also have to exclude the stage2 packages
# [4]. Therefore in this case we also have to exclude the stage2 packages
# from the build.
#
# Because we omit certain packages from the build when CrossCompiling=YES,
......@@ -1536,10 +1526,7 @@ endif
#
# [3] https://ghc.haskell.org/trac/ghc/wiki/Building/CrossCompiling
#
# [4] 5fb72555f7b7ab67a33583f33ad9160761ca434f
# "ghctags needs the stage2 compiler, since it uses the GHC API."
#
# [5] * bc31dbe8ee22819054df60f5ef219fed393a1c54
# [4] * bc31dbe8ee22819054df60f5ef219fed393a1c54
# "Disable any packages built with stage 2 when cross-compiling
# Since we can't run stage 2 on the host."
#
......
......@@ -4,7 +4,7 @@ module Packages (
array, base, binary, bytestring, cabal, checkApiAnnotations, checkPpr,
compareSizes, compiler, containers, deepseq, deriveConstants, directory,
filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact,
ghcHeap, ghci, ghcPkg, ghcPrim, ghcTags, ghcSplit, haddock, haskeline,
ghcHeap, ghci, ghcPkg, ghcPrim, ghcSplit, haddock, haskeline,
hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi,
libiserv, mtl, parsec, parallel, pretty, primitive, process, rts, runGhc,
stm, templateHaskell, terminfo, text, time, timeout, touchy, transformers,
......@@ -33,7 +33,7 @@ ghcPackages =
[ array, base, binary, bytestring, cabal, checkPpr, checkApiAnnotations
, compareSizes, compiler, containers, deepseq, deriveConstants, directory
, filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact
, ghcHeap, ghci, ghcPkg, ghcPrim, ghcTags, haddock, haskeline, hsc2hs, hp2ps
, ghcHeap, ghci, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, hp2ps
, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl
, parsec, parallel, pretty, process, rts, runGhc, stm, templateHaskell
, terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
......@@ -68,7 +68,6 @@ ghcHeap = lib "ghc-heap"
ghci = lib "ghci"
ghcPkg = util "ghc-pkg"
ghcPrim = lib "ghc-prim"
ghcTags = util "ghctags"
ghcSplit = util "ghc-split"
haddock = util "haddock"
haskeline = lib "haskeline"
......
......@@ -108,8 +108,8 @@ stage1Packages = do
, stm
, time
, unlit
, xhtml
, ghcTags ]
, xhtml
]
++ [ haddock | not cross ]
++ [ hpcBin | not cross ]
++ [ iserv | not win, not cross ]
......
# -----------------------------------------------------------------------------
#
# (c) 2009 The University of Glasgow
#
# This file is part of the GHC build system.
#
# To understand how the build system works and how to modify it, see
# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
#
# -----------------------------------------------------------------------------
# Build the tags files for a package. Use like this:
#
# $(eval $(call tags-package,compiler,stage2))
#
# Uses the same metadata as build-package.
define tags-package
$(call trace, tags-package($1,$2))
$(call profStart, tags-package($1,$2))
# $1 = dir
# $2 = distdir
.PHONY: tags_$1
tags_$1:
inplace/bin/ghctags --topdir $$(TOP)/inplace/lib -c --use-cabal-config $1/$2 -- $$($1_$2_TAGS_HC_OPTS) $$($1_$2_v_ALL_HC_OPTS) -- $$($1_$2_HS_SRCS)
.PHONY: TAGS_$1
TAGS_$1:
inplace/bin/ghctags --topdir $$(TOP)/inplace/lib -e --use-cabal-config $1/$2 -- $$($1_$2_TAGS_HC_OPTS) $$($1_$2_v_ALL_HC_OPTS) -- $$($1_$2_HS_SRCS)
$(call profEnd, tags-package($1,$2))
endef
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import Prelude hiding ( mod, id, mapM )
import GHC
--import Packages
import HscTypes ( isBootSummary )
import Digraph ( flattenSCCs )
import DriverPhases ( isHaskellSrcFilename )
import HscTypes ( msHsFilePath )
import Name ( getOccString )
--import ErrUtils ( printBagOfErrors )
import Panic ( panic )
import CmdLineParser (warnMsg)
import DynFlags ( defaultFatalMessager, defaultFlushOut )
import Bag
import Exception
import FastString
import MonadUtils ( liftIO )
import SrcLoc
import Distribution.Simple.GHC ( componentGhcOptions )
import Distribution.Simple.Configure ( getPersistBuildConfig )
import Distribution.Simple.Program.GHC ( renderGhcOptions )
import Distribution.PackageDescription ( libBuildInfo )
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.LocalBuildInfo ( componentNameTargets' )
import Distribution.Types.TargetInfo
import qualified Distribution.Verbosity as V
import Control.Monad hiding (mapM)
import System.Environment
import System.Console.GetOpt
import System.Exit
import System.IO
import Data.List as List hiding ( group )
import Data.Traversable (mapM)
import Data.Map ( Map )
import qualified Data.Map as M
--import UniqFM
--import Debug.Trace
-- search for definitions of things
-- we do this by parsing the source and grabbing top-level definitions
-- We generate both CTAGS and ETAGS format tags files
-- The former is for use in most sensible editors, while EMACS uses ETAGS
----------------------------------
---- CENTRAL DATA TYPES ----------
type FileName = String
type ThingName = String -- name of a defined entity in a Haskell program
-- A definition we have found (we know its containing module, name, and location)
data FoundThing = FoundThing ModuleName ThingName RealSrcLoc
-- Data we have obtained from a file (list of things we found)
data FileData = FileData FileName [FoundThing] (Map Int String)
--- invariant (not checked): every found thing has a source location in that file?
------------------------------
-------- MAIN PROGRAM --------
main :: IO ()
main = do
progName <- getProgName
let usageString =
"Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
args <- getArgs
let (ghcArgs', ourArgs, unbalanced) = splitArgs args
let (flags, filenames, errs) = getOpt Permute options ourArgs
let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
[] -> ""
(x:_) -> x
mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
otherfiles
if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
then do
putStr $ unlines errs
putStr $ usageInfo usageString options
exitWith (ExitFailure 1)
else return ()
ghcArgs <- case [ d | FlagUseCabalConfig d <- flags ] of
[distPref] -> do
cabalOpts <- flagsFromCabal distPref
return (cabalOpts ++ ghcArgs')
[] ->
return ghcArgs'
_ -> error "Too many --use-cabal-config flags"
print ghcArgs
let modes = getMode flags
let openFileMode = if elem FlagAppend flags
then AppendMode
else WriteMode
ctags_hdl <- if CTags `elem` modes
then Just `liftM` openFile "tags" openFileMode
else return Nothing
etags_hdl <- if ETags `elem` modes
then Just `liftM` openFile "TAGS" openFileMode
else return Nothing
GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $
runGhc (Just ghc_topdir) $ do
--liftIO $ print "starting up session"
dflags <- getSessionDynFlags
(pflags, unrec, warns) <- parseDynamicFlags dflags{ verbosity=1 }
(map noLoc ghcArgs)
unless (null unrec) $
liftIO $ putStrLn $ "Unrecognised options:\n" ++ show (map unLoc unrec)
liftIO $ mapM_ putStrLn (map (unLoc . warnMsg) warns)
let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
-- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0
-- Just m -> sizeUFM m)
_ <- setSessionDynFlags dflags2
--liftIO $ print (length pkgs)
targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
----------------------------------------------
---------- ARGUMENT PROCESSING --------------
data Flag
= FlagETags
| FlagCTags
| FlagBoth
| FlagAppend
| FlagHelp
| FlagTopDir FilePath
| FlagUseCabalConfig FilePath
| FlagFilesFromCabal
deriving (Ord, Eq, Show)
-- ^Represents options passed to the program
data Mode = ETags | CTags deriving Eq
getMode :: [Flag] -> [Mode]
getMode fs = go (concatMap modeLike fs)
where go [] = [ETags,CTags]
go [x] = [x]
go more = nub more
modeLike FlagETags = [ETags]
modeLike FlagCTags = [CTags]
modeLike FlagBoth = [ETags,CTags]
modeLike _ = []
splitArgs :: [String] -> ([String], [String], Bool)
-- ^Pull out arguments between -- for GHC
splitArgs args0 = split [] [] False args0
where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
options :: [OptDescr Flag]
-- supports getopt
options = [ Option "" ["topdir"]
(ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
, Option "c" ["ctags"]
(NoArg FlagCTags) "generate CTAGS file (ctags)"
, Option "e" ["etags"]
(NoArg FlagETags) "generate ETAGS file (etags)"
, Option "b" ["both"]
(NoArg FlagBoth) ("generate both CTAGS and ETAGS")
, Option "a" ["append"]
(NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
, Option "" ["use-cabal-config"]
(ReqArg FlagUseCabalConfig "DIR") "use local cabal configuration from dist dir"
, Option "" ["files-from-cabal"]
(NoArg FlagFilesFromCabal) "use files from cabal"
, Option "h" ["help"] (NoArg FlagHelp) "This help"
]
flagsFromCabal :: FilePath -> IO [String]
flagsFromCabal distPref = do
lbi <- getPersistBuildConfig distPref
let pd = localPkgDescr lbi
case componentNameTargets' pd lbi (CLibName LMainLibName) of
[target] ->
let clbi = targetCLBI target
CLib lib = getComponent pd (componentLocalName clbi)
bi = libBuildInfo lib
odir = buildDir lbi
opts = componentGhcOptions V.normal lbi bi clbi odir
in return $ renderGhcOptions (compiler lbi) (hostPlatform lbi) opts
[] -> error "no library"
_ -> error "more libraries than we know how to handle"
----------------------------------------------------------------
--- LOADING HASKELL SOURCE
--- (these bits actually run the compiler and produce abstract syntax)
safeLoad :: LoadHowMuch -> Ghc SuccessFlag
-- like GHC.load, but does not stop process on exception
safeLoad mode = do
_dflags <- getSessionDynFlags
ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $
handleSourceError (\e -> printException e >> return Failed) $
load mode
targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()
-- load a list of targets
targetsAtOneGo hsfiles handles = do
targets <- mapM (\f -> guessTarget f Nothing) hsfiles
setTargets targets
modgraph <- depanal [] False
let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
graphData mods handles
fileTarget :: FileName -> Target
fileTarget filename = Target (TargetFile filename Nothing) True Nothing
---------------------------------------------------------------
----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
graphData :: [ModSummary] -> (Maybe Handle, Maybe Handle) -> Ghc ()
graphData mss handles = do
mapM_ foundthings mss
where foundthings ms =
let filename = msHsFilePath ms
modname = moduleName $ ms_mod ms
in handleSourceError (\e -> do
printException e
liftIO $ exitWith (ExitFailure 1)) $
do liftIO $ putStrLn ("loading " ++ filename)
mod <- loadModule =<< typecheckModule =<< parseModule ms
case mod of
_ | isBootSummary ms -> return ()
_ | Just s <- renamedSource mod ->
liftIO (writeTagsData handles =<< fileData filename modname s)
_otherwise ->
liftIO $ exitWith (ExitFailure 1)
fileData :: FileName -> ModuleName -> RenamedSource -> IO FileData
fileData filename modname (group, _imports, _lie, _doc) = do
-- lie is related to type checking and so is irrelevant
-- imports contains import declarations and no definitions
-- doc and haddock seem haddock-related; let's hope to ignore them
ls <- lines `fmap` readFile filename
let line_map = M.fromAscList $ zip [1..] ls
line_map' <- evaluate line_map
return $ FileData filename (boundValues modname group) line_map'
boundValues :: ModuleName -> HsGroup GhcRn -> [FoundThing]
-- ^Finds all the top-level definitions in a module
boundValues mod group =
let vals = case hs_valds group of
XValBindsLR (NValBinds nest _sigs) ->
[ x | (_rec, binds) <- nest
, bind <- bagToList binds
, x <- boundThings mod bind ]
_other -> error "boundValues"
tys = [ n | ns <- map (fst . hsLTyClDeclBinders)
(hs_tyclds group >>= group_tyclds)
, n <- map found ns ]
fors = concat $ map forBound (hs_fords group)
where forBound lford = case unLoc lford of
ForeignImport _ n _ _ -> [found n]
ForeignExport { } -> []
XForeignDecl { } -> []
in vals ++ tys ++ fors
where found = foundOfLName mod
startOfLocated :: HasSrcSpan a => a -> RealSrcLoc
startOfLocated lHs = case getLoc lHs of
RealSrcSpan l -> realSrcSpanStart l
UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan"
foundOfLName :: ModuleName -> Located Name -> FoundThing
foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
boundThings :: ModuleName -> LHsBind GhcRn -> [FoundThing]
boundThings modname lbinding =
case unLoc lbinding of
FunBind { fun_id = id } -> [thing id]
PatBind { pat_lhs = lhs } -> patThings lhs []
VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
AbsBinds { } -> [] -- nothing interesting in a type abstraction
PatSynBind _ PSB{ psb_id = id } -> [thing id]
PatSynBind _ (XPatSynBind _) -> []
XHsBindsLR _ -> []
where thing = foundOfLName modname
patThings lpat tl =
let loc = startOfLocated lpat
lid id = FoundThing modname (getOccString id) loc
in case unLoc lpat of
WildPat _ -> tl
VarPat _ (L _ name) -> lid name : tl
LazyPat _ p -> patThings p tl
AsPat _ id p -> patThings p (thing id : tl)
ParPat _ p -> patThings p tl
BangPat _ p -> patThings p tl
ListPat _ ps -> foldr patThings tl ps
TuplePat _ ps _ -> foldr patThings tl ps
ConPatIn _ conargs -> conArgs conargs tl
ConPatOut{ pat_args = conargs } -> conArgs conargs tl
LitPat _ _ -> tl
NPat {} -> tl -- form of literal pattern?
NPlusKPat _ id _ _ _ _ -> thing id : tl
SigPat _ p _ -> patThings p tl
_ -> error "boundThings"
conArgs (PrefixCon ps) tl = foldr patThings tl ps
conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
= foldr (\(L _ f) tl' -> patThings (hsRecFieldArg f) tl') tl flds
conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
-- stuff for dealing with ctags output format
writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO ()
writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
writectagsfile :: Handle -> FileData -> IO ()
writectagsfile ctagsfile filedata = do
let things = getfoundthings filedata
mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
getfoundthings :: FileData -> [FoundThing]
getfoundthings (FileData _filename things _src_lines) = things
dumpthing :: Bool -> FoundThing -> String
dumpthing showmod (FoundThing modname name loc) =
fullname ++ "\t" ++ filename ++ "\t" ++ (show line)
where line = srcLocLine loc
filename = unpackFS $ srcLocFile loc
fullname = if showmod then moduleNameString modname ++ "." ++ name
else name
-- stuff for dealing with etags output format
writeetagsfile :: Handle -> FileData -> IO ()
writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
e_dumpfiledata :: FileData -> String
e_dumpfiledata (FileData filename things line_map) =
"\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
where
thingsdump = concat $ map (e_dumpthing line_map) things
thingslength = length thingsdump
e_dumpthing :: Map Int String -> FoundThing -> String
e_dumpthing src_lines (FoundThing modname name loc) =
tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
where tagline n = src_code ++ "\x7f"
++ n ++ "\x01"
++ (show line) ++ "," ++ (show $ column) ++ "\n"
line = srcLocLine loc
column = srcLocCol loc
src_code = case M.lookup line src_lines of
Just l -> take (column + length name) l
Nothing -> --trace (show ("not found: ", moduleNameString modname, name, line, column))
name
This program should eventually replace the lexically-based
tags program. But before this can happen, several problems
must be addressed:
* Performance is disastrous: it takes much longer to run ghctags
than it does to compile GHC
* The program does not use the correct source-code locations
The program accepts both its own arguments and options intended for GHC.
As a quick self-test, you can run
./ghctags -- -package ghc -- GhcTags.hs
# -----------------------------------------------------------------------------
#
# (c) 2009 The University of Glasgow
#
# This file is part of the GHC build system.
#
# To understand how the build system works and how to modify it, see
# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
#
# -----------------------------------------------------------------------------
utils/ghctags_USES_CABAL = YES
utils/ghctags_PACKAGE = ghctags
utils/ghctags_dist-install_PROGNAME = ghctags
utils/ghctags_dist-install_INSTALL = NO
utils/ghctags_dist-install_INSTALL_INPLACE = YES
$(eval $(call build-prog,utils/ghctags,dist-install,2))
Name: ghctags
Version: 0.1
Copyright: XXX
License: BSD3
-- XXX License-File: LICENSE
Author: XXX
Maintainer: XXX
Synopsis: A simple generator of vi- and emacs-compatible TAGS files.
Description: XXX
Category: Development
build-type: Simple
cabal-version: >=1.10
Executable ghctags
Default-Language: Haskell2010
Main-Is: Main.hs
Build-Depends: base >= 4 && < 5,
containers,
Cabal >= 2.5 && <2.6,
ghc
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment