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 -- The position of a token or definition
118 FileName -- file name
121 String -- string that makes up that line
124 srcLocToPos :: SrcLoc -> Pos
126 Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus"
128 -- A definition we have found
129 data FoundThing = FoundThing ThingName Pos
132 -- Data we have obtained from a file
133 data FileData = FileData FileName [FoundThing]
135 data Token = Token String Pos
139 -- stuff for dealing with ctags output format
141 writectagsfile :: Handle -> [FileData] -> IO ()
142 writectagsfile ctagsfile filedata = do
143 let things = concat $ map getfoundthings filedata
144 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
146 getfoundthings :: FileData -> [FoundThing]
147 getfoundthings (FileData filename things) = things
149 dumpthing :: FoundThing -> String
150 dumpthing (FoundThing name (Pos filename line _ _)) =
151 name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
154 -- stuff for dealing with etags output format
156 writeetagsfile :: Handle -> [FileData] -> IO ()
157 writeetagsfile etagsfile filedata = do
158 mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
160 e_dumpfiledata :: FileData -> String
161 e_dumpfiledata (FileData filename things) =
162 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
164 thingsdump = concat $ map e_dumpthing things
165 thingslength = length thingsdump
167 e_dumpthing :: FoundThing -> String
168 e_dumpthing (FoundThing name (Pos filename line token fullline)) =
169 ---- (concat $ take (token + 1) $ spacedwords fullline)
171 ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
174 -- like "words", but keeping the whitespace, and so letting us build
177 spacedwords :: String -> [String]
179 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
181 (blanks,rest) = span Char.isSpace xs
182 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
185 -- Find the definitions in a file
187 modsummary :: ModuleGraph -> FileName -> Maybe ModSummary
189 List.find matches graph
190 where matches ms = n == msHsFilePath ms
192 modname :: ModSummary -> ModuleName
193 modname summary = moduleName $ ms_mod $ summary
195 fileTarget :: FileName -> Target
196 fileTarget filename = Target (TargetFile filename Nothing) Nothing
198 graphData :: Session -> ModuleGraph -> IO [FileData]
199 graphData session graph =
200 mapM foundthings graph
201 where foundthings ms =
202 let filename = msHsFilePath ms
203 in do mod <- checkModule session (moduleName $ ms_mod ms)
205 Nothing -> FileData filename []
206 Just m -> case renamedSource m of
207 Nothing -> FileData filename []
208 Just s -> fileData filename s
211 fileData :: FileName -> RenamedSource -> FileData
212 fileData filename (group, imports, lie) =
213 -- lie is related to type checking and so is irrelevant
214 -- imports contains import declarations and no definitions
215 FileData filename (boundValues group)
217 boundValues :: HsGroup Name -> [FoundThing]
219 let vals = case hs_valds group of
220 ValBindsOut nest sigs ->
221 [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
222 tys = concat $ map tyBound (hs_tyclds group)
223 where tyBound ltcd = case unLoc ltcd of
224 ForeignType { tcdLName = n } -> [foundOfLName n]
225 TyData { tcdLName = n } -> [foundOfLName n]
226 TySynonym { tcdLName = n } -> [foundOfLName n]
227 ClassDecl { tcdLName = n } -> [foundOfLName n]
228 fors = concat $ map forBound (hs_fords group)
229 where forBound lford = case unLoc lford of
230 ForeignImport n _ _ -> [foundOfLName n]
231 ForeignExport { } -> []
232 in vals ++ tys ++ fors
234 posOfLocated :: Located a -> Pos
235 posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
237 foundOfLName :: Located Name -> FoundThing
238 foundOfLName id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
240 boundThings :: LHsBind Name -> [FoundThing]
241 boundThings lbinding =
242 let thing = foundOfLName
243 in case unLoc lbinding of
244 FunBind { fun_id = id } -> [thing id]
245 PatBind { pat_lhs = lhs } -> panic "Pattern at top level"
246 VarBind { var_id = id } -> [FoundThing (getOccString id) (posOfLocated lbinding)]
247 AbsBinds { } -> [] -- nothing interesting in a type abstraction