From 0ca48da78f669b18a574dc18e8b20b5393526b1d Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 21 Feb 2010 16:44:32 +0000 Subject: [PATCH] Make "make tags" work in the new build system --- compiler/ghc.mk | 3 ++ ghc.mk | 6 +++ rules/tags-package.mk | 29 +++++++++++ utils/ghctags/{GhcTags.hs => Main.hs} | 88 +++++++++++++++------------------ utils/ghctags/Makefile | 60 ---------------------- 5 files changed, 77 insertions(+), 109 deletions(-) create mode 100644 rules/tags-package.mk rename utils/ghctags/{GhcTags.hs => Main.hs} (87%) delete mode 100644 utils/ghctags/Makefile diff --git a/compiler/ghc.mk b/compiler/ghc.mk index b33117a..03971be 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -468,6 +468,9 @@ ifeq "$(stage)" "3" $(eval $(call build-package,compiler,stage3,2)) endif +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) diff --git a/ghc.mk b/ghc.mk index a5828a6..768ff15 100644 --- a/ghc.mk +++ b/ghc.mk @@ -269,6 +269,7 @@ 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 # ----------------------------------------------------------------------------- # Registering hand-written package descriptions (used in libffi and rts) @@ -547,6 +548,7 @@ BUILD_DIRS += \ compiler \ $(GHC_HSC2HS_DIR) \ $(GHC_PKG_DIR) \ + utils/ghctags \ utils/hpc \ utils/runghc \ ghc @@ -597,6 +599,7 @@ ifneq "$(findstring $(phase),0 1 2 3)" "" # In phases 0-3, we disable stage2-3, the full libraries and haddock utils/haddock_dist_DISABLE = YES utils/runghc_dist_DISABLE = YES +utils/ghctags_dist_DISABLE = YES utils/hpc_dist_DISABLE = YES utils/hsc2hs_dist-install_DISABLE = YES utils/ghc-pkg_dist-install_DISABLE = YES @@ -745,6 +748,9 @@ libraries/ghc-prim/dist-install/build/autogen/GHC/PrimopWrappers.hs: \ | $$(dir $$@)/. "$(GENPRIMOP_INPLACE)" --make-haskell-wrappers < $< > $@ +.PHONY: tags +tags: tags_compiler + # ----------------------------------------------------------------------------- # Installation diff --git a/rules/tags-package.mk b/rules/tags-package.mk new file mode 100644 index 0000000..e5d572d --- /dev/null +++ b/rules/tags-package.mk @@ -0,0 +1,29 @@ +# ----------------------------------------------------------------------------- +# +# (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://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.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 +# $1 = dir +# $2 = distdir + +.PHONY: tags_$1 +tags_$1: + inplace/bin/ghctags --topdir $$(TOP)/inplace/lib -b --use-cabal-config $1/$2 -- $$($1_$2_TAGS_HC_OPTS) $$($1_$2_v_ALL_HC_OPTS) -- $$($1_$2_HS_SRCS) + +endef + diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/Main.hs similarity index 87% rename from utils/ghctags/GhcTags.hs rename to utils/ghctags/Main.hs index e74b2d1..9017bd0 100644 --- a/utils/ghctags/GhcTags.hs +++ b/utils/ghctags/Main.hs @@ -1,20 +1,18 @@ -{-# OPTIONS_GHC -XCPP -XPatternGuards -XScopedTypeVariables -Wall #-} +{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} module Main where import Prelude hiding ( mod, id, mapM ) import GHC hiding (flags) --import Packages import HscTypes ( isBootSummary ) -import BasicTypes import Digraph ( flattenSCCs ) import DriverPhases ( isHaskellSrcFilename ) import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) import DynFlags ( defaultDynFlags ) -import SrcLoc import Bag -import Exception -- ( ghandle ) +import Exception import FastString import MonadUtils ( liftIO ) @@ -22,16 +20,14 @@ import MonadUtils ( liftIO ) import Distribution.Simple.GHC ( ghcOptions ) import Distribution.Simple.Configure ( getPersistBuildConfig ) import Distribution.PackageDescription ( library, libBuildInfo ) -import Distribution.Simple.LocalBuildInfo ( localPkgDescr, buildDir ) +import Distribution.Simple.LocalBuildInfo ( localPkgDescr, buildDir, libraryConfig ) import Control.Monad hiding (mapM) import System.Environment import System.Console.GetOpt import System.Exit -import Data.Char import System.IO import Data.List as List hiding ( group ) -import Data.Maybe import Data.Traversable (mapM) import Data.Map ( Map ) import qualified Data.Map as M @@ -87,7 +83,7 @@ main = do ghcArgs <- case [ d | FlagUseCabalConfig d <- flags ] of [distPref] -> do cabalOpts <- flagsFromCabal distPref - return (ghcArgs' ++ cabalOpts) + return (cabalOpts ++ ghcArgs') [] -> return ghcArgs' _ -> error "Too many --use-cabal-config flags" @@ -95,8 +91,8 @@ main = do let modes = getMode flags let openFileMode = if elem FlagAppend flags - then AppendMode - else WriteMode + then AppendMode + else WriteMode ctags_hdl <- if CTags `elem` modes then Just `liftM` openFile "tags" openFileMode else return Nothing @@ -116,11 +112,11 @@ main = do let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything -- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0 -- Just m -> sizeUFM m) - setSessionDynFlags dflags2 + _ <- setSessionDynFlags dflags2 --liftIO $ print (length pkgs) GHC.defaultCleanupHandler dflags2 $ do - + targetsAtOneGo hsfiles (ctags_hdl,etags_hdl) mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl] @@ -161,34 +157,34 @@ splitArgs args0 = split [] [] False args0 options :: [OptDescr Flag] -- supports getopt -options = [ Option "" ["topdir"] +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)") + (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" - ] + , Option "h" ["help"] (NoArg FlagHelp) "This help" + ] flagsFromCabal :: FilePath -> IO [String] flagsFromCabal distPref = do lbi <- getPersistBuildConfig distPref let pd = localPkgDescr lbi - case library pd of - Nothing -> error "no library" - Just lib -> + case (library pd, libraryConfig lbi) of + (Just lib, Just clbi) -> let bi = libBuildInfo lib odir = buildDir lbi - opts = ghcOptions lbi bi odir + opts = ghcOptions lbi bi clbi odir in return opts + _ -> error "no library" ---------------------------------------------------------------- --- LOADING HASKELL SOURCE @@ -237,16 +233,16 @@ graphData graph handles = do liftIO $ exitWith (ExitFailure 1) fileData :: FileName -> ModuleName -> RenamedSource -> IO FileData -fileData filename modname (group, _imports, _lie, _doc, _haddock) = do +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 - evaluate line_map - return $ FileData filename (boundValues modname group) line_map + line_map' <- evaluate line_map + return $ FileData filename (boundValues modname group) line_map' -boundValues :: ModuleName -> HsGroup Name -> [FoundThing] +boundValues :: ModuleName -> HsGroup Name -> [FoundThing] -- ^Finds all the top-level definitions in a module boundValues mod group = let vals = case hs_valds group of @@ -262,9 +258,7 @@ boundValues mod group = ForeignImport n _ _ -> [found n] ForeignExport { } -> [] in vals ++ tys ++ fors - where dataNames tycon cons = found tycon : map conName cons - conName td = found $ con_name $ unLoc td - found = foundOfLName mod + where found = foundOfLName mod startOfLocated :: Located a -> SrcLoc startOfLocated lHs = srcSpanStart $ getLoc lHs @@ -273,7 +267,7 @@ foundOfLName :: ModuleName -> Located Name -> FoundThing foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id) boundThings :: ModuleName -> LHsBind Name -> [FoundThing] -boundThings modname lbinding = +boundThings modname lbinding = case unLoc lbinding of FunBind { fun_id = id } -> [thing id] PatBind { pat_lhs = lhs } -> patThings lhs [] @@ -297,18 +291,14 @@ boundThings modname lbinding = ConPatIn _ conargs -> conArgs conargs tl ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl LitPat _ -> tl -#if __GLASGOW_HASKELL__ > 608 NPat _ _ _ -> tl -- form of literal pattern? -#else - NPat _ _ _ _ -> tl -- form of literal pattern? -#endif NPlusKPat id _ _ _ -> thing id : tl TypePat _ -> tl -- XXX need help here SigPatIn p _ -> patThings p tl SigPatOut p _ -> patThings p tl _ -> error "boundThings" conArgs (PrefixCon ps) tl = foldr patThings tl ps - conArgs (RecCon (HsRecFields { rec_flds = flds })) tl + conArgs (RecCon (HsRecFields { rec_flds = flds })) tl = foldr (\f tl' -> patThings (hsRecFieldArg f) tl') tl flds conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl @@ -316,22 +306,22 @@ boundThings modname lbinding = -- stuff for dealing with ctags output format writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO () -writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do +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 + 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) + fullname ++ "\t" ++ filename ++ "\t" ++ (show line) where line = srcLocLine loc filename = unpackFS $ srcLocFile loc fullname = if showmod then moduleNameString modname ++ "." ++ name @@ -344,10 +334,10 @@ 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 + "\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) = @@ -359,5 +349,5 @@ e_dumpthing src_lines (FoundThing modname name 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)) + Nothing -> --trace (show ("not found: ", moduleNameString modname, name, line, column)) name diff --git a/utils/ghctags/Makefile b/utils/ghctags/Makefile deleted file mode 100644 index d3a59ff..0000000 --- a/utils/ghctags/Makefile +++ /dev/null @@ -1,60 +0,0 @@ -TOP=../.. -include $(TOP)/mk/boilerplate.mk - -SRC_HC_OPTS += -package ghc - -HC=$(GHC_STAGE1) - -# On Windows, ghc-pkg is a standalone program -# ($bindir/ghc-pkg.exe), whereas on Unix it needs a wrapper script -# to pass the appropriate flag to the real binary -# ($libexecdir/ghc-pkg.bin) so that it can find package.conf. -ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" -HS_PROG = ghctags.exe -INSTALL_PROGS += $(HS_PROG) -else -HS_PROG = ghctags.bin -INSTALL_LIBEXECS += $(HS_PROG) -endif - -# ----------------------------------------------------------------------------- -# ghctags and ghctags-inplace scripts - -# See commentary in ../ghc-pkg/Makefile - -INPLACE_HS=ghctags-inplace.hs -INPLACE_PROG=ghctags-inplace -EXCLUDED_SRCS+=$(INPLACE_HS) - -$(INPLACE_HS): Makefile $(FPTOOLS_TOP)/mk/config.mk - echo "import System.Cmd; import System.Environment; import System.Exit" > $@ - echo "main = do args <- getArgs; rawSystem \"$(FPTOOLS_TOP_ABS)/$(GHC_GHCTAGS_DIR_REL)/$(HS_PROG)\" (\"--topdir\":\"$(FPTOOLS_TOP_ABS)\":args) >>= exitWith" >> $@ - -$(INPLACE_PROG): $(INPLACE_HS) - $(HC) --make $< -o $@ - -all :: $(INPLACE_PROG) - -CLEAN_FILES += $(INPLACE_HS) $(INPLACE_PROG) - -ifneq "$(HOSTPLATFORM)" "i386-unknown-mingw32" -LINK = ghctags -LINK_TARGET = $(LINK)-$(ProjectVersion) -INSTALLED_SCRIPT=$(DESTDIR)$(bindir)/$(LINK_TARGET) -install:: - $(INSTALL_DIR) $(DESTDIR)$(bindir) - $(RM) -f $(INSTALLED_SCRIPT) - echo "#!$(SHELL)" >> $(INSTALLED_SCRIPT) - echo "GHCTAGSBIN=$(libexecdir)/$(HS_PROG)" >> $(INSTALLED_SCRIPT) - echo "TOPDIR=$(libdir)" >> $(INSTALLED_SCRIPT) - echo 'exec $$GHCTAGSBIN --topdir $$TOPDIR $${1+"$$@"}' >> $(INSTALLED_SCRIPT) - $(EXECUTABLE_FILE) $(INSTALLED_SCRIPT) -endif - -binary-dist: - $(INSTALL_DIR) $(BIN_DIST_DIR)/utils/ghctags - $(INSTALL_DATA) Makefile $(BIN_DIST_DIR)/utils/ghctags/ - $(INSTALL_PROGRAM) $(HS_PROG) $(BIN_DIST_DIR)/utils/ghctags/ - -include $(TOP)/mk/target.mk - -- 1.7.10.4