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