1 {-# OPTIONS_GHC -XCPP -XPatternGuards -XScopedTypeVariables -Wall #-}
4 import GHC hiding (flags)
5 import HscTypes ( isBootSummary )
7 import Digraph ( flattenSCCs )
8 import DriverPhases ( isHaskellSrcFilename )
9 import HscTypes ( msHsFilePath )
10 import Name ( getOccString )
11 import ErrUtils ( printBagOfErrors )
12 import DynFlags ( defaultDynFlags )
15 import Exception -- ( ghandle )
17 import MonadUtils ( liftIO )
19 import Prelude hiding (mapM)
20 import Control.Monad hiding (mapM)
21 import System.Environment
22 import System.Console.GetOpt
26 import Data.List as List
28 import Data.Traversable (mapM)
30 -- search for definitions of things
31 -- we do this by parsing the source and grabbing top-level definitions
33 -- We generate both CTAGS and ETAGS format tags files
34 -- The former is for use in most sensible editors, while EMACS uses ETAGS
36 ----------------------------------
37 ---- CENTRAL DATA TYPES ----------
39 type FileName = String
40 type ThingName = String -- name of a defined entity in a Haskell program
42 -- A definition we have found (we know its containing module, name, and location)
43 data FoundThing = FoundThing ModuleName ThingName SrcLoc
45 -- Data we have obtained from a file (list of things we found)
46 data FileData = FileData FileName [FoundThing]
47 --- invariant (not checked): every found thing has a source location in that file?
50 ------------------------------
51 -------- MAIN PROGRAM --------
55 progName <- getProgName
57 "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
59 let (ghcArgs, ourArgs, unbalanced) = splitArgs args
60 let (flags, filenames, errs) = getOpt Permute options ourArgs
61 let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
62 let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
65 mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
67 if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
70 putStr $ usageInfo usageString options
71 exitWith (ExitFailure 1)
74 let modes = getMode flags
75 let openFileMode = if elem FlagAppend flags
78 ctags_hdl <- if CTags `elem` modes
79 then Just `liftM` openFile "tags" openFileMode
81 etags_hdl <- if ETags `elem` modes
82 then Just `liftM` openFile "TAGS" openFileMode
85 GHC.defaultErrorHandler defaultDynFlags $
86 runGhc (Just ghc_topdir) $ do
87 dflags <- getSessionDynFlags
88 (pflags, _, _) <- parseDynamicFlags dflags{ verbosity=1 } (map noLoc ghcArgs)
89 let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
90 GHC.defaultCleanupHandler dflags2 $ do
92 setSessionDynFlags dflags2
93 targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
94 mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
96 ----------------------------------------------
97 ---------- ARGUMENT PROCESSING --------------
105 | FlagTopDir FilePath
106 deriving (Ord, Eq, Show)
107 -- ^Represents options passed to the program
109 data Mode = ETags | CTags deriving Eq
111 getMode :: [Flag] -> [Mode]
112 getMode fs = go (concatMap modeLike fs)
113 where go [] = [ETags,CTags]
117 modeLike FlagETags = [ETags]
118 modeLike FlagCTags = [CTags]
119 modeLike FlagBoth = [ETags,CTags]
122 splitArgs :: [String] -> ([String], [String], Bool)
123 -- ^Pull out arguments between -- for GHC
124 splitArgs args = split [] [] False args
125 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
126 split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
127 split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
129 options :: [OptDescr Flag]
131 options = [ Option "" ["topdir"]
132 (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
133 , Option "c" ["ctags"]
134 (NoArg FlagCTags) "generate CTAGS file (ctags)"
135 , Option "e" ["etags"]
136 (NoArg FlagETags) "generate ETAGS file (etags)"
137 , Option "b" ["both"]
138 (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
139 , Option "a" ["append"]
140 (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
141 , Option "h" ["help"] (NoArg FlagHelp) "This help"
145 ----------------------------------------------------------------
146 --- LOADING HASKELL SOURCE
147 --- (these bits actually run the compiler and produce abstract syntax)
149 safeLoad :: LoadHowMuch -> Ghc SuccessFlag
150 -- like GHC.load, but does not stop process on exception
152 dflags <- getSessionDynFlags
153 ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $
154 handleSourceError (\e -> printExceptionAndWarnings e >> return Failed) $
158 targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()
159 -- load a list of targets
160 targetsAtOneGo hsfiles handles = do
161 targets <- mapM (\f -> guessTarget f Nothing) hsfiles
163 modgraph <- depanal [] False
164 let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
165 graphData mods handles
167 fileTarget :: FileName -> Target
168 fileTarget filename = Target (TargetFile filename Nothing) True Nothing
170 ---------------------------------------------------------------
171 ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
173 graphData :: ModuleGraph -> (Maybe Handle, Maybe Handle) -> Ghc ()
174 graphData graph handles = do
175 mapM_ foundthings graph
176 where foundthings ms =
177 let filename = msHsFilePath ms
178 modname = moduleName $ ms_mod ms
179 in do liftIO $ putStrLn ("loading " ++ filename)
180 mod <- loadModule =<< typecheckModule =<< parseModule ms
182 _ | isBootSummary ms -> return ()
183 _ | Just s <- renamedSource mod ->
184 liftIO $ writeTagsData handles (fileData filename modname s)
186 liftIO $ exitWith (ExitFailure 1)
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 _other -> error "boundValues"
203 tys = concat $ map tyBound (hs_tyclds group)
204 where tyBound ltcd = case unLoc ltcd of
205 ForeignType { tcdLName = n } -> [found n]
206 TyData { tcdLName = tycon, tcdCons = cons } ->
208 TySynonym { tcdLName = n } -> [found n]
209 ClassDecl { tcdLName = n } -> [found n]
210 _ -> error "boundValues: tys"
211 fors = concat $ map forBound (hs_fords group)
212 where forBound lford = case unLoc lford of
213 ForeignImport n _ _ -> [found n]
214 ForeignExport { } -> []
215 in vals ++ tys ++ fors
216 where dataNames tycon cons = found tycon : map conName cons
217 conName td = found $ con_name $ unLoc td
218 found = foundOfLName mod
220 startOfLocated :: Located a -> SrcLoc
221 startOfLocated lHs = srcSpanStart $ getLoc lHs
223 foundOfLName :: ModuleName -> Located Name -> FoundThing
224 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
226 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
227 boundThings modname lbinding =
228 case unLoc lbinding of
229 FunBind { fun_id = id } -> [thing id]
230 PatBind { pat_lhs = lhs } -> patThings lhs []
231 VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
232 AbsBinds { } -> [] -- nothing interesting in a type abstraction
233 where thing = foundOfLName modname
235 let loc = startOfLocated lpat
236 lid id = FoundThing modname (getOccString id) loc
237 in case unLoc lpat of
239 VarPat name -> lid name : tl
240 VarPatOut name _ -> lid name : tl -- XXX need help here
241 LazyPat p -> patThings p tl
242 AsPat id p -> patThings p (thing id : tl)
243 ParPat p -> patThings p tl
244 BangPat p -> patThings p tl
245 ListPat ps _ -> foldr patThings tl ps
246 TuplePat ps _ _ -> foldr patThings tl ps
247 PArrPat ps _ -> foldr patThings tl ps
248 ConPatIn _ conargs -> conArgs conargs tl
249 ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
251 #if __GLASGOW_HASKELL__ > 608
252 NPat _ _ _ -> tl -- form of literal pattern?
254 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
260 _ -> error "boundThings"
261 conArgs (PrefixCon ps) tl = foldr patThings tl ps
262 conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
263 = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl flds
264 conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
267 -- stuff for dealing with ctags output format
269 writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO ()
270 writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
271 maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
272 maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
274 writectagsfile :: Handle -> FileData -> IO ()
275 writectagsfile ctagsfile filedata = do
276 let things = getfoundthings filedata
277 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
278 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
280 getfoundthings :: FileData -> [FoundThing]
281 getfoundthings (FileData _filename things) = things
283 dumpthing :: Bool -> FoundThing -> String
284 dumpthing showmod (FoundThing modname name loc) =
285 fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
286 where line = srcLocLine loc
287 filename = unpackFS $ srcLocFile loc
288 fullname = if showmod then moduleNameString modname ++ "." ++ name
291 -- stuff for dealing with etags output format
293 writeetagsfile :: Handle -> FileData -> IO ()
294 writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
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