1 {-# OPTIONS_GHC -XCPP #-}
6 import Digraph ( flattenSCCs )
7 import DriverPhases ( isHaskellSrcFilename )
8 import HscTypes (msHsFilePath)
11 import ErrUtils ( printBagOfErrors )
12 import DynFlags(GhcMode, defaultDynFlags)
15 import Util ( handle, handleDyn )
19 import System.Environment
20 import System.Console.GetOpt
24 import Data.List as List
27 -- search for definitions of things
28 -- we do this by parsing the source and grabbing top-level definitions
30 -- We generate both CTAGS and ETAGS format tags files
31 -- The former is for use in most sensible editors, while EMACS uses ETAGS
33 ----------------------------------
34 ---- CENTRAL DATA TYPES ----------
36 type FileName = String
37 type ThingName = String -- name of a defined entity in a Haskell program
39 -- A definition we have found (we know its containing module, name, and location)
40 data FoundThing = FoundThing ModuleName ThingName SrcLoc
42 -- Data we have obtained from a file (list of things we found)
43 data FileData = FileData FileName [FoundThing]
44 --- invariant (not checked): every found thing has a source location in that file?
47 ------------------------------
48 -------- MAIN PROGRAM --------
52 progName <- getProgName
54 "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
56 let (ghcArgs, ourArgs, unbalanced) = splitArgs args
57 let (flags, filenames, errs) = getOpt Permute options ourArgs
58 let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
59 let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
62 mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
64 if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
67 putStr $ usageInfo usageString options
68 exitWith (ExitFailure 1)
71 let modes = getMode flags
72 let openFileMode = if elem FlagAppend flags
75 ctags_hdl <- if CTags `elem` modes
76 then Just `liftM` openFile "tags" openFileMode
78 etags_hdl <- if ETags `elem` modes
79 then Just `liftM` openFile "TAGS" openFileMode
82 GHC.defaultErrorHandler defaultDynFlags $ do
83 session <- newSession (Just ghc_topdir)
84 flags <- getSessionDynFlags session
85 (pflags, _) <- parseDynamicFlags flags{ verbosity=1 } ghcArgs
86 let flags = pflags { hscTarget = HscNothing } -- don't generate anything
87 GHC.defaultCleanupHandler flags $ do
89 setSessionDynFlags session flags
90 targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl)
92 ----------------------------------------------
93 ---------- ARGUMENT PROCESSING --------------
101 | FlagTopDir FilePath
102 deriving (Ord, Eq, Show)
103 -- ^Represents options passed to the program
105 data Mode = ETags | CTags deriving Eq
107 getMode :: [Flag] -> [Mode]
108 getMode fs = go (concatMap modeLike fs)
109 where go [] = [ETags,CTags]
113 modeLike FlagETags = [ETags]
114 modeLike FlagCTags = [CTags]
115 modeLike FlagBoth = [ETags,CTags]
118 splitArgs :: [String] -> ([String], [String], Bool)
119 -- ^Pull out arguments between -- for GHC
120 splitArgs args = split [] [] False args
121 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
122 split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
123 split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
125 options :: [OptDescr Flag]
127 options = [ Option "" ["topdir"]
128 (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
129 , Option "c" ["ctags"]
130 (NoArg FlagCTags) "generate CTAGS file (ctags)"
131 , Option "e" ["etags"]
132 (NoArg FlagETags) "generate ETAGS file (etags)"
133 , Option "b" ["both"]
134 (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
135 , Option "a" ["append"]
136 (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
137 , Option "h" ["help"] (NoArg FlagHelp) "This help"
141 ----------------------------------------------------------------
142 --- LOADING HASKELL SOURCE
143 --- (these bits actually run the compiler and produce abstract syntax)
145 safeLoad :: Session -> LoadHowMuch -> IO SuccessFlag
146 -- like GHC.load, but does not stop process on exception
147 safeLoad session mode = do
148 dflags <- getSessionDynFlags session
149 handle (\exception -> return Failed ) $
150 handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
151 return Failed) $ load session mode
154 targetsAtOneGo :: Session -> [FileName] -> (Maybe Handle, Maybe Handle) -> IO ()
155 -- load a list of targets
156 targetsAtOneGo session hsfiles handles = do
157 targets <- mapM (\f -> guessTarget f Nothing) hsfiles
158 setTargets session targets
159 putStrLn $ "Load it all:"
160 flag <- load session LoadAllTargets
161 when (failed flag) $ exitWith (ExitFailure 1)
162 modgraph <- getModuleGraph session
163 let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
164 graphData session mods handles
166 where targetInfo [hs] = "target " ++ hs
167 targetInfo hss = show (length hss) ++ " targets at one go"
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 mod <- checkModule session modname False
182 let fd = maybe (FileData filename []) id $ do
185 return $ fileData filename modname s
186 writeTagsData handles fd
188 fileData :: FileName -> ModuleName -> RenamedSource -> FileData
189 fileData filename modname (group, _imports, _lie, _doc, _haddock) =
190 -- lie is related to type checking and so is irrelevant
191 -- imports contains import declarations and no definitions
192 -- doc and haddock seem haddock-related; let's hope to ignore them
193 FileData filename (boundValues modname group)
195 boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
196 -- ^Finds all the top-level definitions in a module
197 boundValues mod group =
198 let vals = case hs_valds group of
199 ValBindsOut nest sigs ->
200 [ x | (_rec, binds) <- nest, bind <- bagToList binds,
201 x <- boundThings mod bind ]
202 tys = concat $ map tyBound (hs_tyclds group)
203 where tyBound ltcd = case unLoc ltcd of
204 ForeignType { tcdLName = n } -> [found n]
205 TyData { tcdLName = tycon, tcdCons = cons } ->
207 TySynonym { tcdLName = n } -> [found n]
208 ClassDecl { tcdLName = n } -> [found n]
209 fors = concat $ map forBound (hs_fords group)
210 where forBound lford = case unLoc lford of
211 ForeignImport n _ _ -> [found n]
212 ForeignExport { } -> []
213 in vals ++ tys ++ fors
214 where dataNames tycon cons = found tycon : map conName cons
215 conName td = found $ con_name $ unLoc td
216 found = foundOfLName mod
218 startOfLocated :: Located a -> SrcLoc
219 startOfLocated lHs = srcSpanStart $ getLoc lHs
221 foundOfLName :: ModuleName -> Located Name -> FoundThing
222 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
224 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
225 boundThings modname lbinding =
226 case unLoc lbinding of
227 FunBind { fun_id = id } -> [thing id]
228 PatBind { pat_lhs = lhs } -> patThings lhs []
229 VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
230 AbsBinds { } -> [] -- nothing interesting in a type abstraction
231 where thing = foundOfLName modname
233 let loc = startOfLocated lpat
234 lid id = FoundThing modname (getOccString id) loc
235 in case unLoc lpat of
237 VarPat name -> lid name : tl
238 VarPatOut name _ -> lid name : tl -- XXX need help here
239 LazyPat p -> patThings p tl
240 AsPat id p -> patThings p (thing id : tl)
241 ParPat p -> patThings p tl
242 BangPat p -> patThings p tl
243 ListPat ps _ -> foldr patThings tl ps
244 TuplePat ps _ _ -> foldr patThings tl ps
245 PArrPat ps _ -> foldr patThings tl ps
246 ConPatIn _ conargs -> conArgs conargs tl
247 ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
249 #if __GLASGOW_HASKELL__ > 608
250 NPat _ _ _ -> tl -- form of literal pattern?
252 NPat _ _ _ _ -> tl -- form of literal pattern?
254 NPlusKPat id _ _ _ -> thing id : tl
255 TypePat _ -> tl -- XXX need help here
256 SigPatIn p _ -> patThings p tl
257 SigPatOut p _ -> patThings p tl
258 conArgs (PrefixCon ps) tl = foldr patThings tl ps
259 conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
260 = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl flds
261 conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
264 -- stuff for dealing with ctags output format
266 writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
267 maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
268 maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
270 writectagsfile :: Handle -> FileData -> IO ()
271 writectagsfile ctagsfile filedata = do
272 let things = getfoundthings filedata
273 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
274 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
276 getfoundthings :: FileData -> [FoundThing]
277 getfoundthings (FileData filename things) = things
279 dumpthing :: Bool -> FoundThing -> String
280 dumpthing showmod (FoundThing modname name loc) =
281 fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
282 where line = srcLocLine loc
283 filename = unpackFS $ srcLocFile loc
284 fullname = if showmod then moduleNameString modname ++ "." ++ name
287 -- stuff for dealing with etags output format
289 writeetagsfile :: Handle -> FileData -> IO ()
290 writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
292 e_dumpfiledata :: FileData -> String
293 e_dumpfiledata (FileData filename things) =
294 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
296 thingsdump = concat $ map e_dumpthing things
297 thingslength = length thingsdump
299 e_dumpthing :: FoundThing -> String
300 e_dumpthing (FoundThing modname name loc) =
301 tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
302 where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
303 line = srcLocLine loc