4 import DriverPhases ( isHaskellSrcFilename )
5 import HscTypes (msHsFilePath)
8 import ErrUtils ( printBagOfErrors )
9 import DynFlags(GhcMode, defaultDynFlags)
12 import Util ( handle, handleDyn )
15 import System.Environment
16 import System.Console.GetOpt
20 import Data.List as List
23 -- search for definitions of things
24 -- we do this by parsing the source and grabbing top-level definitions
26 -- We generate both CTAGS and ETAGS format tags files
27 -- The former is for use in most sensible editors, while EMACS uses ETAGS
29 ---------------------------------
30 --------- CONFIGURATION ---------
32 ghcRootDir = "/usr/local/lib/ghc-6.5" --- root for -package ghc? (passed to GHC.init)
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 (modes, filenames, errs) = getOpt Permute options ourArgs
60 let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
61 mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
63 if unbalanced || errs /= [] || elem Help modes || hsfiles == []
66 putStr $ usageInfo usageString options
67 exitWith (ExitFailure 1)
69 GHC.defaultErrorHandler defaultDynFlags $ do
70 session <- newSession (Just ghcRootDir)
71 flags <- getSessionDynFlags session
72 (pflags, _) <- parseDynamicFlags flags ghcArgs
73 let flags = pflags { hscTarget = HscNothing } -- don't generate anything
74 GHC.defaultCleanupHandler flags $ do
75 setSessionDynFlags session flags
76 -- targets <- mapM (\s -> guessTarget s Nothing) hsfiles
77 -- guessTarget would be more compatible with ghc -M
78 filedata <- targetsAtOneGo session hsfiles
79 filedata <- case filedata of
81 Nothing -> targetsOneAtATime session hsfiles
82 emitTagsData modes filedata
85 ----------------------------------------------
86 ---------- ARGUMENT PROCESSING --------------
88 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
89 -- ^Represents options passed to the program
91 -- | getMode takes a list of modes and extract the mode with the
92 -- highest precedence. These are as follows: Both, CTags, ETags
93 -- The default case is Both.
94 getMode :: [Mode] -> Mode
97 getMode (x:xs) = max x (getMode xs)
100 splitArgs :: [String] -> ([String], [String], Bool)
101 -- ^Pull out arguments between -- for GHC
102 splitArgs args = split [] [] False args
103 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
104 split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
105 split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
107 options :: [OptDescr Mode]
109 options = [ Option "c" ["ctags"]
110 (NoArg CTags) "generate CTAGS file (ctags)"
111 , Option "e" ["etags"]
112 (NoArg ETags) "generate ETAGS file (etags)"
113 , Option "b" ["both"]
114 (NoArg BothTags) ("generate both CTAGS and ETAGS")
115 , Option "a" ["append"]
116 (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
117 , Option "h" ["help"] (NoArg Help) "This help"
121 ----------------------------------------------------------------
122 --- LOADING HASKELL SOURCE
123 --- (these bits actually run the compiler and produce abstract syntax)
125 safeLoad :: Session -> LoadHowMuch -> IO SuccessFlag
126 -- like GHC.load, but does not stop process on exception
127 safeLoad session mode = do
128 dflags <- getSessionDynFlags session
129 handle (\exception -> return Failed ) $
130 handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
131 return Failed) $ load session mode
134 targetsAtOneGo :: Session -> [FileName] -> IO (Maybe [FileData])
135 -- load a list of targets
136 targetsAtOneGo session hsfiles = do
137 let targets = map fileTarget hsfiles
138 setTargets session targets
139 print $ "trying " ++ targetInfo hsfiles
140 success <- safeLoad session LoadAllTargets --- bring module graph up to date
142 Failed -> return Nothing
144 print $ "loaded " ++ targetInfo hsfiles
145 graph <- getModuleGraph session
146 print "got modules graph"
147 fd <- graphData session graph
150 where targetInfo [hs] = "target " ++ hs
151 targetInfo hss = show (length hss) ++ " targets at one go"
153 targetsOneAtATime :: Session -> [FileName] -> IO ([FileData])
154 -- load a list of targets, one at a time (more resilient to errors)
155 targetsOneAtATime session hsfiles = do
156 print "trying targets one by one"
157 results <- mapM (targetsAtOneGo session) [[f] | f <- hsfiles]
158 return $ List.concat $ catMaybes results
160 fileTarget :: FileName -> Target
161 fileTarget filename = Target (TargetFile filename Nothing) Nothing
163 ---------------------------------------------------------------
164 ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
166 graphData :: Session -> ModuleGraph -> IO [FileData]
167 graphData session graph =
168 mapM foundthings graph
169 where foundthings ms =
170 let filename = msHsFilePath ms
171 modname = moduleName $ ms_mod ms
172 in do mod <- checkModule session modname False
173 return $ maybe (FileData filename []) id $ do
176 return $ fileData filename modname s
178 fileData :: FileName -> ModuleName -> RenamedSource -> FileData
179 fileData filename modname (group, _imports, _lie, _doc, _haddock) =
180 -- lie is related to type checking and so is irrelevant
181 -- imports contains import declarations and no definitions
182 -- doc and haddock seem haddock-related; let's hope to ignore them
183 FileData filename (boundValues modname group)
185 boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
186 -- ^Finds all the top-level definitions in a module
187 boundValues mod group =
188 let vals = case hs_valds group of
189 ValBindsOut nest sigs ->
190 [ x | (_rec, binds) <- nest, bind <- bagToList binds,
191 x <- boundThings mod bind ]
192 tys = concat $ map tyBound (hs_tyclds group)
193 where tyBound ltcd = case unLoc ltcd of
194 ForeignType { tcdLName = n } -> [found n]
195 TyData { tcdLName = tycon, tcdCons = cons } ->
197 TySynonym { tcdLName = n } -> [found n]
198 ClassDecl { tcdLName = n } -> [found n]
199 fors = concat $ map forBound (hs_fords group)
200 where forBound lford = case unLoc lford of
201 ForeignImport n _ _ -> [found n]
202 ForeignExport { } -> []
203 in vals ++ tys ++ fors
204 where dataNames tycon cons = found tycon : map conName cons
205 conName td = found $ con_name $ unLoc td
206 found = foundOfLName mod
208 startOfLocated :: Located a -> SrcLoc
209 startOfLocated lHs = srcSpanStart $ getLoc lHs
211 foundOfLName :: ModuleName -> Located Name -> FoundThing
212 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
214 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
215 boundThings modname lbinding =
216 case unLoc lbinding of
217 FunBind { fun_id = id } -> [thing id]
218 PatBind { pat_lhs = lhs } -> patThings lhs []
219 VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
220 AbsBinds { } -> [] -- nothing interesting in a type abstraction
221 where thing = foundOfLName modname
223 let loc = startOfLocated lpat
224 lid id = FoundThing modname (getOccString id) loc
225 in case unLoc lpat of
227 VarPat name -> lid name : tl
228 VarPatOut name _ -> lid name : tl -- XXX need help here
229 LazyPat p -> patThings p tl
230 AsPat id p -> patThings p (thing id : tl)
231 ParPat p -> patThings p tl
232 BangPat p -> patThings p tl
233 ListPat ps _ -> foldr patThings tl ps
234 TuplePat ps _ _ -> foldr patThings tl ps
235 PArrPat ps _ -> foldr patThings tl ps
236 ConPatIn _ conargs -> conArgs conargs tl
237 ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
239 NPat _ _ _ _ -> tl -- form of literal pattern?
240 NPlusKPat id _ _ _ -> thing id : tl
241 TypePat _ -> tl -- XXX need help here
242 SigPatIn p _ -> patThings p tl
243 SigPatOut p _ -> patThings p tl
244 conArgs (PrefixCon ps) tl = foldr patThings tl ps
245 conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
246 = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl flds
247 conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
250 -----------------------------------------------
251 ------- WRITING THE DATA TO TAGS FILES --------
253 emitTagsData :: [Mode] -> [FileData] -> IO ()
254 emitTagsData modes filedata = do
255 let mode = getMode (Append `delete` modes)
256 let openFileMode = if elem Append modes
259 if mode == BothTags || mode == CTags
261 ctagsfile <- openFile "tags" openFileMode
262 writectagsfile ctagsfile filedata
265 if mode == BothTags || mode == ETags
267 etagsfile <- openFile "TAGS" openFileMode
268 writeetagsfile etagsfile filedata
273 -- stuff for dealing with ctags output format
275 writectagsfile :: Handle -> [FileData] -> IO ()
276 writectagsfile ctagsfile filedata = do
277 let things = concat $ map getfoundthings filedata
278 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
279 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
281 getfoundthings :: FileData -> [FoundThing]
282 getfoundthings (FileData filename things) = things
284 dumpthing :: Bool -> FoundThing -> String
285 dumpthing showmod (FoundThing modname name loc) =
286 fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
287 where line = srcLocLine loc
288 filename = unpackFS $ srcLocFile loc
289 fullname = if showmod then moduleNameString modname ++ "." ++ name
292 -- stuff for dealing with etags output format
294 writeetagsfile :: Handle -> [FileData] -> IO ()
295 writeetagsfile etagsfile filedata = do
296 mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
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