1 {-# OPTIONS_GHC -XCPP -XPatternGuards -Wall #-}
4 import GHC hiding (flags)
5 import HscTypes ( isBootSummary )
7 import Digraph ( flattenSCCs )
8 import DriverPhases ( isHaskellSrcFilename )
9 import HscTypes ( msHsFilePath )
10 import Name ( getOccString )
11 import ErrUtils ( printBagOfErrors )
12 import DynFlags ( defaultDynFlags )
15 import Util ( handle, handleDyn )
18 import Prelude hiding (mapM)
19 import Control.Monad hiding (mapM)
20 import System.Environment
21 import System.Console.GetOpt
25 import Data.List as List
27 import Data.Traversable (mapM)
29 -- search for definitions of things
30 -- we do this by parsing the source and grabbing top-level definitions
32 -- We generate both CTAGS and ETAGS format tags files
33 -- The former is for use in most sensible editors, while EMACS uses ETAGS
35 ----------------------------------
36 ---- CENTRAL DATA TYPES ----------
38 type FileName = String
39 type ThingName = String -- name of a defined entity in a Haskell program
41 -- A definition we have found (we know its containing module, name, and location)
42 data FoundThing = FoundThing ModuleName ThingName SrcLoc
44 -- Data we have obtained from a file (list of things we found)
45 data FileData = FileData FileName [FoundThing]
46 --- invariant (not checked): every found thing has a source location in that file?
49 ------------------------------
50 -------- MAIN PROGRAM --------
54 progName <- getProgName
56 "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
58 let (ghcArgs, ourArgs, unbalanced) = splitArgs args
59 let (flags, filenames, errs) = getOpt Permute options ourArgs
60 let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
61 let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
64 mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
66 if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
69 putStr $ usageInfo usageString options
70 exitWith (ExitFailure 1)
73 let modes = getMode flags
74 let openFileMode = if elem FlagAppend flags
77 ctags_hdl <- if CTags `elem` modes
78 then Just `liftM` openFile "tags" openFileMode
80 etags_hdl <- if ETags `elem` modes
81 then Just `liftM` openFile "TAGS" openFileMode
84 GHC.defaultErrorHandler defaultDynFlags $ do
85 session <- newSession (Just ghc_topdir)
86 dflags <- getSessionDynFlags session
87 (pflags, _) <- parseDynamicFlags dflags{ verbosity=1 } ghcArgs
88 let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
89 GHC.defaultCleanupHandler dflags2 $ do
91 setSessionDynFlags session dflags2
92 targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl)
93 mapM_ (mapM hClose) [ctags_hdl, etags_hdl]
95 ----------------------------------------------
96 ---------- ARGUMENT PROCESSING --------------
104 | FlagTopDir FilePath
105 deriving (Ord, Eq, Show)
106 -- ^Represents options passed to the program
108 data Mode = ETags | CTags deriving Eq
110 getMode :: [Flag] -> [Mode]
111 getMode fs = go (concatMap modeLike fs)
112 where go [] = [ETags,CTags]
116 modeLike FlagETags = [ETags]
117 modeLike FlagCTags = [CTags]
118 modeLike FlagBoth = [ETags,CTags]
121 splitArgs :: [String] -> ([String], [String], Bool)
122 -- ^Pull out arguments between -- for GHC
123 splitArgs args = split [] [] False args
124 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
125 split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
126 split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
128 options :: [OptDescr Flag]
130 options = [ Option "" ["topdir"]
131 (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
132 , Option "c" ["ctags"]
133 (NoArg FlagCTags) "generate CTAGS file (ctags)"
134 , Option "e" ["etags"]
135 (NoArg FlagETags) "generate ETAGS file (etags)"
136 , Option "b" ["both"]
137 (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
138 , Option "a" ["append"]
139 (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
140 , Option "h" ["help"] (NoArg FlagHelp) "This help"
144 ----------------------------------------------------------------
145 --- LOADING HASKELL SOURCE
146 --- (these bits actually run the compiler and produce abstract syntax)
148 safeLoad :: Session -> LoadHowMuch -> IO SuccessFlag
149 -- like GHC.load, but does not stop process on exception
150 safeLoad session mode = do
151 dflags <- getSessionDynFlags session
152 handle (\_exception -> return Failed ) $
153 handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
154 return Failed) $ load session mode
157 targetsAtOneGo :: Session -> [FileName] -> (Maybe Handle, Maybe Handle) -> IO ()
158 -- load a list of targets
159 targetsAtOneGo session hsfiles handles = do
160 targets <- mapM (\f -> guessTarget f Nothing) hsfiles
161 setTargets session targets
162 mb_modgraph <- depanal session [] False
164 Nothing -> exitWith (ExitFailure 1)
166 let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
167 graphData session mods handles
169 fileTarget :: FileName -> Target
170 fileTarget filename = Target (TargetFile filename Nothing) Nothing
172 ---------------------------------------------------------------
173 ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
175 graphData :: Session -> ModuleGraph -> (Maybe Handle, Maybe Handle) -> IO ()
176 graphData session graph handles = do
177 mapM_ foundthings graph
178 where foundthings ms =
179 let filename = msHsFilePath ms
180 modname = moduleName $ ms_mod ms
181 in do putStrLn ("loading " ++ filename)
182 mb_mod <- checkAndLoadModule session ms False
184 _ | isBootSummary ms -> return ()
185 Just mod | Just s <- renamedSource mod ->
186 writeTagsData handles (fileData filename modname s)
188 exitWith (ExitFailure 1)
190 fileData :: FileName -> ModuleName -> RenamedSource -> FileData
191 fileData filename modname (group, _imports, _lie, _doc, _haddock) =
192 -- lie is related to type checking and so is irrelevant
193 -- imports contains import declarations and no definitions
194 -- doc and haddock seem haddock-related; let's hope to ignore them
195 FileData filename (boundValues modname group)
197 boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
198 -- ^Finds all the top-level definitions in a module
199 boundValues mod group =
200 let vals = case hs_valds group of
201 ValBindsOut nest _sigs ->
202 [ x | (_rec, binds) <- nest, bind <- bagToList binds,
203 x <- boundThings mod bind ]
204 _other -> error "boundValues"
205 tys = concat $ map tyBound (hs_tyclds group)
206 where tyBound ltcd = case unLoc ltcd of
207 ForeignType { tcdLName = n } -> [found n]
208 TyData { tcdLName = tycon, tcdCons = cons } ->
210 TySynonym { tcdLName = n } -> [found n]
211 ClassDecl { tcdLName = n } -> [found n]
212 _ -> error "boundValues: tys"
213 fors = concat $ map forBound (hs_fords group)
214 where forBound lford = case unLoc lford of
215 ForeignImport n _ _ -> [found n]
216 ForeignExport { } -> []
217 in vals ++ tys ++ fors
218 where dataNames tycon cons = found tycon : map conName cons
219 conName td = found $ con_name $ unLoc td
220 found = foundOfLName mod
222 startOfLocated :: Located a -> SrcLoc
223 startOfLocated lHs = srcSpanStart $ getLoc lHs
225 foundOfLName :: ModuleName -> Located Name -> FoundThing
226 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
228 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
229 boundThings modname lbinding =
230 case unLoc lbinding of
231 FunBind { fun_id = id } -> [thing id]
232 PatBind { pat_lhs = lhs } -> patThings lhs []
233 VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
234 AbsBinds { } -> [] -- nothing interesting in a type abstraction
235 where thing = foundOfLName modname
237 let loc = startOfLocated lpat
238 lid id = FoundThing modname (getOccString id) loc
239 in case unLoc lpat of
241 VarPat name -> lid name : tl
242 VarPatOut name _ -> lid name : tl -- XXX need help here
243 LazyPat p -> patThings p tl
244 AsPat id p -> patThings p (thing id : tl)
245 ParPat p -> patThings p tl
246 BangPat p -> patThings p tl
247 ListPat ps _ -> foldr patThings tl ps
248 TuplePat ps _ _ -> foldr patThings tl ps
249 PArrPat ps _ -> foldr patThings tl ps
250 ConPatIn _ conargs -> conArgs conargs tl
251 ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
253 #if __GLASGOW_HASKELL__ > 608
254 NPat _ _ _ -> tl -- form of literal pattern?
256 NPat _ _ _ _ -> tl -- form of literal pattern?
258 NPlusKPat id _ _ _ -> thing id : tl
259 TypePat _ -> tl -- XXX need help here
260 SigPatIn p _ -> patThings p tl
261 SigPatOut p _ -> patThings p tl
262 _ -> error "boundThings"
263 conArgs (PrefixCon ps) tl = foldr patThings tl ps
264 conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
265 = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl flds
266 conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
269 -- stuff for dealing with ctags output format
271 writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO ()
272 writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
273 maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
274 maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
276 writectagsfile :: Handle -> FileData -> IO ()
277 writectagsfile ctagsfile filedata = do
278 let things = getfoundthings filedata
279 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
280 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
282 getfoundthings :: FileData -> [FoundThing]
283 getfoundthings (FileData _filename things) = things
285 dumpthing :: Bool -> FoundThing -> String
286 dumpthing showmod (FoundThing modname name loc) =
287 fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
288 where line = srcLocLine loc
289 filename = unpackFS $ srcLocFile loc
290 fullname = if showmod then moduleNameString modname ++ "." ++ name
293 -- stuff for dealing with etags output format
295 writeetagsfile :: Handle -> FileData -> IO ()
296 writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
298 e_dumpfiledata :: FileData -> String
299 e_dumpfiledata (FileData filename things) =
300 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
302 thingsdump = concat $ map e_dumpthing things
303 thingslength = length thingsdump
305 e_dumpthing :: FoundThing -> String
306 e_dumpthing (FoundThing modname name loc) =
307 tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
308 where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
309 line = srcLocLine loc