1 {-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4 import Prelude hiding ( mod, id, mapM )
5 import GHC hiding (flags)
7 import HscTypes ( isBootSummary )
8 import Digraph ( flattenSCCs )
9 import DriverPhases ( isHaskellSrcFilename )
10 import HscTypes ( msHsFilePath )
11 import Name ( getOccString )
12 --import ErrUtils ( printBagOfErrors )
13 import Panic ( panic )
14 import DynFlags ( defaultDynFlags )
18 import MonadUtils ( liftIO )
20 -- Every GHC comes with Cabal anyways, so this is not a bad new dependency
21 import Distribution.Simple.GHC ( ghcOptions )
22 import Distribution.Simple.Configure ( getPersistBuildConfig )
23 import Distribution.PackageDescription ( library, libBuildInfo )
24 import Distribution.Simple.LocalBuildInfo ( localPkgDescr, buildDir, libraryConfig )
26 import Control.Monad hiding (mapM)
27 import System.Environment
28 import System.Console.GetOpt
31 import Data.List as List hiding ( group )
32 import Data.Traversable (mapM)
33 import Data.Map ( Map )
34 import qualified Data.Map as M
39 -- search for definitions of things
40 -- we do this by parsing the source and grabbing top-level definitions
42 -- We generate both CTAGS and ETAGS format tags files
43 -- The former is for use in most sensible editors, while EMACS uses ETAGS
45 ----------------------------------
46 ---- CENTRAL DATA TYPES ----------
48 type FileName = String
49 type ThingName = String -- name of a defined entity in a Haskell program
51 -- A definition we have found (we know its containing module, name, and location)
52 data FoundThing = FoundThing ModuleName ThingName SrcLoc
54 -- Data we have obtained from a file (list of things we found)
55 data FileData = FileData FileName [FoundThing] (Map Int String)
56 --- invariant (not checked): every found thing has a source location in that file?
59 ------------------------------
60 -------- MAIN PROGRAM --------
64 progName <- getProgName
66 "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
68 let (ghcArgs', ourArgs, unbalanced) = splitArgs args
69 let (flags, filenames, errs) = getOpt Permute options ourArgs
70 let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
72 let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
75 mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
77 if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
80 putStr $ usageInfo usageString options
81 exitWith (ExitFailure 1)
84 ghcArgs <- case [ d | FlagUseCabalConfig d <- flags ] of
86 cabalOpts <- flagsFromCabal distPref
87 return (cabalOpts ++ ghcArgs')
90 _ -> error "Too many --use-cabal-config flags"
93 let modes = getMode flags
94 let openFileMode = if elem FlagAppend flags
97 ctags_hdl <- if CTags `elem` modes
98 then Just `liftM` openFile "tags" openFileMode
100 etags_hdl <- if ETags `elem` modes
101 then Just `liftM` openFile "TAGS" openFileMode
104 GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $
105 runGhc (Just ghc_topdir) $ do
106 --liftIO $ print "starting up session"
107 dflags <- getSessionDynFlags
108 (pflags, unrec, warns) <- parseDynamicFlags dflags{ verbosity=1 }
110 unless (null unrec) $
111 liftIO $ putStrLn $ "Unrecognised options:\n" ++ show (map unLoc unrec)
112 liftIO $ mapM_ putStrLn (map unLoc warns)
113 let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
114 -- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0
115 -- Just m -> sizeUFM m)
116 _ <- setSessionDynFlags dflags2
117 --liftIO $ print (length pkgs)
119 GHC.defaultCleanupHandler dflags2 $ do
121 targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
122 mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
124 ----------------------------------------------
125 ---------- ARGUMENT PROCESSING --------------
133 | FlagTopDir FilePath
134 | FlagUseCabalConfig FilePath
136 deriving (Ord, Eq, Show)
137 -- ^Represents options passed to the program
139 data Mode = ETags | CTags deriving Eq
141 getMode :: [Flag] -> [Mode]
142 getMode fs = go (concatMap modeLike fs)
143 where go [] = [ETags,CTags]
147 modeLike FlagETags = [ETags]
148 modeLike FlagCTags = [CTags]
149 modeLike FlagBoth = [ETags,CTags]
152 splitArgs :: [String] -> ([String], [String], Bool)
153 -- ^Pull out arguments between -- for GHC
154 splitArgs args0 = split [] [] False args0
155 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
156 split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
157 split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
159 options :: [OptDescr Flag]
161 options = [ Option "" ["topdir"]
162 (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
163 , Option "c" ["ctags"]
164 (NoArg FlagCTags) "generate CTAGS file (ctags)"
165 , Option "e" ["etags"]
166 (NoArg FlagETags) "generate ETAGS file (etags)"
167 , Option "b" ["both"]
168 (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
169 , Option "a" ["append"]
170 (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
171 , Option "" ["use-cabal-config"]
172 (ReqArg FlagUseCabalConfig "DIR") "use local cabal configuration from dist dir"
173 , Option "" ["files-from-cabal"]
174 (NoArg FlagFilesFromCabal) "use files from cabal"
175 , Option "h" ["help"] (NoArg FlagHelp) "This help"
178 flagsFromCabal :: FilePath -> IO [String]
179 flagsFromCabal distPref = do
180 lbi <- getPersistBuildConfig distPref
181 let pd = localPkgDescr lbi
182 case (library pd, libraryConfig lbi) of
183 (Just lib, Just clbi) ->
184 let bi = libBuildInfo lib
186 opts = ghcOptions lbi bi clbi odir
188 _ -> error "no library"
190 ----------------------------------------------------------------
191 --- LOADING HASKELL SOURCE
192 --- (these bits actually run the compiler and produce abstract syntax)
194 safeLoad :: LoadHowMuch -> Ghc SuccessFlag
195 -- like GHC.load, but does not stop process on exception
197 _dflags <- getSessionDynFlags
198 ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $
199 handleSourceError (\e -> printException e >> return Failed) $
203 targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()
204 -- load a list of targets
205 targetsAtOneGo hsfiles handles = do
206 targets <- mapM (\f -> guessTarget f Nothing) hsfiles
208 modgraph <- depanal [] False
209 let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
210 graphData mods handles
212 fileTarget :: FileName -> Target
213 fileTarget filename = Target (TargetFile filename Nothing) True Nothing
215 ---------------------------------------------------------------
216 ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
218 graphData :: ModuleGraph -> (Maybe Handle, Maybe Handle) -> Ghc ()
219 graphData graph handles = do
220 mapM_ foundthings graph
221 where foundthings ms =
222 let filename = msHsFilePath ms
223 modname = moduleName $ ms_mod ms
224 in handleSourceError (\e -> do
226 liftIO $ exitWith (ExitFailure 1)) $
227 do liftIO $ putStrLn ("loading " ++ filename)
228 mod <- loadModule =<< typecheckModule =<< parseModule ms
230 _ | isBootSummary ms -> return ()
231 _ | Just s <- renamedSource mod ->
232 liftIO (writeTagsData handles =<< fileData filename modname s)
234 liftIO $ exitWith (ExitFailure 1)
236 fileData :: FileName -> ModuleName -> RenamedSource -> IO FileData
237 fileData filename modname (group, _imports, _lie, _doc) = do
238 -- lie is related to type checking and so is irrelevant
239 -- imports contains import declarations and no definitions
240 -- doc and haddock seem haddock-related; let's hope to ignore them
241 ls <- lines `fmap` readFile filename
242 let line_map = M.fromAscList $ zip [1..] ls
243 line_map' <- evaluate line_map
244 return $ FileData filename (boundValues modname group) line_map'
246 boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
247 -- ^Finds all the top-level definitions in a module
248 boundValues mod group =
249 let vals = case hs_valds group of
250 ValBindsOut nest _sigs ->
251 [ x | (_rec, binds) <- nest
252 , bind <- bagToList binds
253 , x <- boundThings mod bind ]
254 _other -> error "boundValues"
255 tys = [ n | ns <- map hsTyClDeclBinders (concat (hs_tyclds group))
256 , n <- map found ns ]
257 fors = concat $ map forBound (hs_fords group)
258 where forBound lford = case unLoc lford of
259 ForeignImport n _ _ -> [found n]
260 ForeignExport { } -> []
261 in vals ++ tys ++ fors
262 where found = foundOfLName mod
264 startOfLocated :: Located a -> SrcLoc
265 startOfLocated lHs = srcSpanStart $ getLoc lHs
267 foundOfLName :: ModuleName -> Located Name -> FoundThing
268 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
270 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
271 boundThings modname lbinding =
272 case unLoc lbinding of
273 FunBind { fun_id = id } -> [thing id]
274 PatBind { pat_lhs = lhs } -> patThings lhs []
275 VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
276 AbsBinds { } -> [] -- nothing interesting in a type abstraction
277 where thing = foundOfLName modname
279 let loc = startOfLocated lpat
280 lid id = FoundThing modname (getOccString id) loc
281 in case unLoc lpat of
283 VarPat name -> lid name : tl
284 LazyPat p -> patThings p tl
285 AsPat id p -> patThings p (thing id : tl)
286 ParPat p -> patThings p tl
287 BangPat p -> patThings p tl
288 ListPat ps _ -> foldr patThings tl ps
289 TuplePat ps _ _ -> foldr patThings tl ps
290 PArrPat ps _ -> foldr patThings tl ps
291 ConPatIn _ conargs -> conArgs conargs tl
292 ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
294 NPat _ _ _ -> tl -- form of literal pattern?
295 NPlusKPat id _ _ _ -> thing id : tl
296 SigPatIn p _ -> patThings p tl
297 SigPatOut p _ -> patThings p tl
298 _ -> error "boundThings"
299 conArgs (PrefixCon ps) tl = foldr patThings tl ps
300 conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
301 = foldr (\f tl' -> patThings (hsRecFieldArg f) tl') tl flds
302 conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
305 -- stuff for dealing with ctags output format
307 writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO ()
308 writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
309 maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
310 maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
312 writectagsfile :: Handle -> FileData -> IO ()
313 writectagsfile ctagsfile filedata = do
314 let things = getfoundthings filedata
315 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
316 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
318 getfoundthings :: FileData -> [FoundThing]
319 getfoundthings (FileData _filename things _src_lines) = things
321 dumpthing :: Bool -> FoundThing -> String
322 dumpthing showmod (FoundThing modname name loc) =
323 fullname ++ "\t" ++ filename ++ "\t" ++ (show line)
324 where line = srcLocLine loc
325 filename = unpackFS $ srcLocFile loc
326 fullname = if showmod then moduleNameString modname ++ "." ++ name
329 -- stuff for dealing with etags output format
331 writeetagsfile :: Handle -> FileData -> IO ()
332 writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
334 e_dumpfiledata :: FileData -> String
335 e_dumpfiledata (FileData filename things line_map) =
336 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
338 thingsdump = concat $ map (e_dumpthing line_map) things
339 thingslength = length thingsdump
341 e_dumpthing :: Map Int String -> FoundThing -> String
342 e_dumpthing src_lines (FoundThing modname name loc) =
343 tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
344 where tagline n = src_code ++ "\x7f"
346 ++ (show line) ++ "," ++ (show $ column) ++ "\n"
347 line = srcLocLine loc
348 column = srcLocCol loc
349 src_code = case M.lookup line src_lines of
350 Just l -> take (column + length name) l
351 Nothing -> --trace (show ("not found: ", moduleNameString modname, name, line, column))