4 import DynFlags(GhcMode, defaultDynFlags)
7 import HscTypes (msHsFilePath)
13 import System.Environment
14 import System.Console.GetOpt
18 -- search for definitions of things
19 -- we do this by parsing the source and grabbing top-level definitions
21 -- We generate both CTAGS and ETAGS format tags files
22 -- The former is for use in most sensible editors, while EMACS uses ETAGS
26 placateGhc = defaultErrorHandler defaultDynFlags $ do
27 GHC.init (Just "/usr/local/lib/ghc-6.5") -- or your build tree!
33 progName <- getProgName
35 "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
37 let (ghcArgs, ourArgs, unbalanced) = splitArgs args
38 let (modes, filenames, errs) = getOpt Permute options ourArgs
39 if unbalanced || errs /= [] || elem Help modes || filenames == []
42 putStr $ usageInfo usageString options
43 exitWith (ExitFailure 1)
45 let mode = getMode (Append `delete` modes)
46 let openFileMode = if elem Append modes
49 GHC.init (Just "/usr/local/lib/ghc-6.5")
50 GHC.defaultErrorHandler defaultDynFlags $ do
51 session <- newSession JustTypecheck
52 print "created a session"
53 flags <- getSessionDynFlags session
54 (pflags, _) <- parseDynamicFlags flags ghcArgs
55 let flags = pflags { hscTarget = HscNothing }
56 GHC.defaultCleanupHandler flags $ do
57 flags <- initPackages flags
58 setSessionDynFlags session flags
59 setTargets session (map fileTarget filenames)
61 success <- load session LoadAllTargets --- bring module graph up to date
62 filedata <- case success of
63 Failed -> do { putStr "Load failed"; exitWith (ExitFailure 2) }
65 print "loaded all targets"
66 graph <- getModuleGraph session
67 print "got modules graph"
68 graphData session graph
69 if mode == BothTags || mode == CTags
71 ctagsfile <- openFile "tags" openFileMode
72 writectagsfile ctagsfile filedata
75 if mode == BothTags || mode == ETags
77 etagsfile <- openFile "TAGS" openFileMode
78 writeetagsfile etagsfile filedata
82 -- | getMode takes a list of modes and extract the mode with the
83 -- highest precedence. These are as follows: Both, CTags, ETags
84 -- The default case is Both.
85 getMode :: [Mode] -> Mode
88 getMode (x:xs) = max x (getMode xs)
91 splitArgs :: [String] -> ([String], [String], Bool)
92 -- pull out arguments between -- for GHC
93 splitArgs args = split [] [] False args
94 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
95 split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
96 split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
98 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
100 options :: [OptDescr Mode]
101 options = [ Option "c" ["ctags"]
102 (NoArg CTags) "generate CTAGS file (ctags)"
103 , Option "e" ["etags"]
104 (NoArg ETags) "generate ETAGS file (etags)"
105 , Option "b" ["both"]
106 (NoArg BothTags) ("generate both CTAGS and ETAGS")
107 , Option "a" ["append"]
108 (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
109 , Option "h" ["help"] (NoArg Help) "This help"
112 type FileName = String
114 type ThingName = String
116 -- A definition we have found
117 data FoundThing = FoundThing ModuleName ThingName SrcLoc
119 -- Data we have obtained from a file
120 data FileData = FileData FileName [FoundThing]
122 -- stuff for dealing with ctags output format
124 writectagsfile :: Handle -> [FileData] -> IO ()
125 writectagsfile ctagsfile filedata = do
126 let things = concat $ map getfoundthings filedata
127 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
129 getfoundthings :: FileData -> [FoundThing]
130 getfoundthings (FileData filename things) = things
132 dumpthing :: FoundThing -> String
133 dumpthing (FoundThing modname name loc) =
134 name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
135 where line = srcLocLine loc
136 filename = unpackFS $ srcLocFile loc
139 -- stuff for dealing with etags output format
141 writeetagsfile :: Handle -> [FileData] -> IO ()
142 writeetagsfile etagsfile filedata = do
143 mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
145 e_dumpfiledata :: FileData -> String
146 e_dumpfiledata (FileData filename things) =
147 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
149 thingsdump = concat $ map e_dumpthing things
150 thingslength = length thingsdump
152 e_dumpthing :: FoundThing -> String
153 e_dumpthing (FoundThing modname name loc) =
154 tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
155 where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
156 line = srcLocLine loc
160 -- like "words", but keeping the whitespace, and so letting us build
163 spacedwords :: String -> [String]
165 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
167 (blanks,rest) = span Char.isSpace xs
168 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
171 -- Find the definitions in a file
173 modsummary :: ModuleGraph -> FileName -> Maybe ModSummary
175 List.find matches graph
176 where matches ms = n == msHsFilePath ms
178 modname :: ModSummary -> ModuleName
179 modname summary = moduleName $ ms_mod $ summary
181 fileTarget :: FileName -> Target
182 fileTarget filename = Target (TargetFile filename Nothing) Nothing
184 graphData :: Session -> ModuleGraph -> IO [FileData]
185 graphData session graph =
186 mapM foundthings graph
187 where foundthings ms =
188 let filename = msHsFilePath ms
189 modname = moduleName $ ms_mod ms
190 in do mod <- checkModule session modname
191 return $ maybe (FileData filename []) id $ do
194 return $ fileData filename modname s
196 fileData :: FileName -> ModuleName -> RenamedSource -> FileData
197 fileData filename modname (group, imports, lie) =
198 -- lie is related to type checking and so is irrelevant
199 -- imports contains import declarations and no definitions
200 FileData filename (boundValues modname group)
202 boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
203 boundValues mod group =
204 let vals = case hs_valds group of
205 ValBindsOut nest sigs ->
206 [ x | (_rec, binds) <- nest, bind <- bagToList binds,
207 x <- boundThings mod bind ]
208 tys = concat $ map tyBound (hs_tyclds group)
209 where tyBound ltcd = case unLoc ltcd of
210 ForeignType { tcdLName = n } -> [found n]
211 TyData { tcdLName = tycon, tcdCons = cons } ->
213 TySynonym { tcdLName = n } -> [found n]
214 ClassDecl { tcdLName = n } -> [found n]
215 fors = concat $ map forBound (hs_fords group)
216 where forBound lford = case unLoc lford of
217 ForeignImport n _ _ -> [found n]
218 ForeignExport { } -> []
219 in vals ++ tys ++ fors
220 where dataNames tycon cons = found tycon : map conName cons
221 conName td = found $ con_name $ unLoc td
222 found = foundOfLName mod
224 startOfLocated :: Located a -> SrcLoc
225 startOfLocated lHs = srcSpanStart $ getLoc lHs
227 foundOfLName :: ModuleName -> Located Name -> FoundThing
228 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
230 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
231 boundThings modname lbinding =
232 case unLoc lbinding of
233 FunBind { fun_id = id } -> [thing id]
234 PatBind { pat_lhs = lhs } -> patThings lhs []
235 VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
236 AbsBinds { } -> [] -- nothing interesting in a type abstraction
237 where thing = foundOfLName modname
239 let loc = startOfLocated lpat
240 lid id = FoundThing modname (getOccString id) loc
241 in case unLoc lpat of
243 VarPat name -> lid name : tl
244 VarPatOut name _ -> lid name : tl -- XXX need help here
245 LazyPat p -> patThings p tl
246 AsPat id p -> patThings p (thing id : tl)
247 ParPat p -> patThings p tl
248 BangPat p -> patThings p tl
249 ListPat ps _ -> foldr patThings tl ps
250 TuplePat ps _ _ -> foldr patThings tl ps
251 PArrPat ps _ -> foldr patThings tl ps
252 ConPatIn _ conargs -> conArgs conargs tl
253 ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
255 NPat _ _ _ _ -> tl -- form of literal pattern?
256 NPlusKPat id _ _ _ -> thing id : tl
257 TypePat _ -> tl -- XXX need help here
258 SigPatIn p _ -> patThings p tl
259 SigPatOut p _ -> patThings p tl
261 conArgs (PrefixCon ps) tl = foldr patThings tl ps
262 conArgs (RecCon pairs) tl = foldr (\(_id, p) tl -> patThings p tl) tl pairs
263 conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl