Update parsec submodule
[ghc.git] / utils / ghctags / Main.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2 {-# LANGUAGE TypeFamilies #-}
3 module Main where
4
5 import Prelude hiding ( mod, id, mapM )
6 import GHC
7 --import Packages
8 import HscTypes ( isBootSummary )
9 import Digraph ( flattenSCCs )
10 import DriverPhases ( isHaskellSrcFilename )
11 import HscTypes ( msHsFilePath )
12 import Name ( getOccString )
13 --import ErrUtils ( printBagOfErrors )
14 import Panic ( panic )
15 import CmdLineParser (warnMsg)
16 import DynFlags ( defaultFatalMessager, defaultFlushOut )
17 import Bag
18 import Exception
19 import FastString
20 import MonadUtils ( liftIO )
21 import SrcLoc
22
23 import Distribution.Simple.GHC ( componentGhcOptions )
24 import Distribution.Simple.Configure ( getPersistBuildConfig )
25 import Distribution.Simple.Program.GHC ( renderGhcOptions )
26 import Distribution.PackageDescription ( libBuildInfo )
27 import Distribution.Simple.LocalBuildInfo
28 import Distribution.Types.LocalBuildInfo ( componentNameTargets' )
29 import Distribution.Types.TargetInfo
30 import qualified Distribution.Verbosity as V
31
32 import Control.Monad hiding (mapM)
33 import System.Environment
34 import System.Console.GetOpt
35 import System.Exit
36 import System.IO
37 import Data.List as List hiding ( group )
38 import Data.Traversable (mapM)
39 import Data.Map ( Map )
40 import qualified Data.Map as M
41
42 --import UniqFM
43 --import Debug.Trace
44
45 -- search for definitions of things
46 -- we do this by parsing the source and grabbing top-level definitions
47
48 -- We generate both CTAGS and ETAGS format tags files
49 -- The former is for use in most sensible editors, while EMACS uses ETAGS
50
51 ----------------------------------
52 ---- CENTRAL DATA TYPES ----------
53
54 type FileName = String
55 type ThingName = String -- name of a defined entity in a Haskell program
56
57 -- A definition we have found (we know its containing module, name, and location)
58 data FoundThing = FoundThing ModuleName ThingName RealSrcLoc
59
60 -- Data we have obtained from a file (list of things we found)
61 data FileData = FileData FileName [FoundThing] (Map Int String)
62 --- invariant (not checked): every found thing has a source location in that file?
63
64
65 ------------------------------
66 -------- MAIN PROGRAM --------
67
68 main :: IO ()
69 main = do
70 progName <- getProgName
71 let usageString =
72 "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
73 args <- getArgs
74 let (ghcArgs', ourArgs, unbalanced) = splitArgs args
75 let (flags, filenames, errs) = getOpt Permute options ourArgs
76 let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
77
78 let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
79 [] -> ""
80 (x:_) -> x
81 mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
82 otherfiles
83 if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
84 then do
85 putStr $ unlines errs
86 putStr $ usageInfo usageString options
87 exitWith (ExitFailure 1)
88 else return ()
89
90 ghcArgs <- case [ d | FlagUseCabalConfig d <- flags ] of
91 [distPref] -> do
92 cabalOpts <- flagsFromCabal distPref
93 return (cabalOpts ++ ghcArgs')
94 [] ->
95 return ghcArgs'
96 _ -> error "Too many --use-cabal-config flags"
97 print ghcArgs
98
99 let modes = getMode flags
100 let openFileMode = if elem FlagAppend flags
101 then AppendMode
102 else WriteMode
103 ctags_hdl <- if CTags `elem` modes
104 then Just `liftM` openFile "tags" openFileMode
105 else return Nothing
106 etags_hdl <- if ETags `elem` modes
107 then Just `liftM` openFile "TAGS" openFileMode
108 else return Nothing
109
110 GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $
111 runGhc (Just ghc_topdir) $ do
112 --liftIO $ print "starting up session"
113 dflags <- getSessionDynFlags
114 (pflags, unrec, warns) <- parseDynamicFlags dflags{ verbosity=1 }
115 (map noLoc ghcArgs)
116 unless (null unrec) $
117 liftIO $ putStrLn $ "Unrecognised options:\n" ++ show (map unLoc unrec)
118 liftIO $ mapM_ putStrLn (map (unLoc . warnMsg) warns)
119 let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
120 -- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0
121 -- Just m -> sizeUFM m)
122 _ <- setSessionDynFlags dflags2
123 --liftIO $ print (length pkgs)
124
125 targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
126 mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
127
128 ----------------------------------------------
129 ---------- ARGUMENT PROCESSING --------------
130
131 data Flag
132 = FlagETags
133 | FlagCTags
134 | FlagBoth
135 | FlagAppend
136 | FlagHelp
137 | FlagTopDir FilePath
138 | FlagUseCabalConfig FilePath
139 | FlagFilesFromCabal
140 deriving (Ord, Eq, Show)
141 -- ^Represents options passed to the program
142
143 data Mode = ETags | CTags deriving Eq
144
145 getMode :: [Flag] -> [Mode]
146 getMode fs = go (concatMap modeLike fs)
147 where go [] = [ETags,CTags]
148 go [x] = [x]
149 go more = nub more
150
151 modeLike FlagETags = [ETags]
152 modeLike FlagCTags = [CTags]
153 modeLike FlagBoth = [ETags,CTags]
154 modeLike _ = []
155
156 splitArgs :: [String] -> ([String], [String], Bool)
157 -- ^Pull out arguments between -- for GHC
158 splitArgs args0 = split [] [] False args0
159 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
160 split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
161 split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
162
163 options :: [OptDescr Flag]
164 -- supports getopt
165 options = [ Option "" ["topdir"]
166 (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
167 , Option "c" ["ctags"]
168 (NoArg FlagCTags) "generate CTAGS file (ctags)"
169 , Option "e" ["etags"]
170 (NoArg FlagETags) "generate ETAGS file (etags)"
171 , Option "b" ["both"]
172 (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
173 , Option "a" ["append"]
174 (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
175 , Option "" ["use-cabal-config"]
176 (ReqArg FlagUseCabalConfig "DIR") "use local cabal configuration from dist dir"
177 , Option "" ["files-from-cabal"]
178 (NoArg FlagFilesFromCabal) "use files from cabal"
179 , Option "h" ["help"] (NoArg FlagHelp) "This help"
180 ]
181
182 flagsFromCabal :: FilePath -> IO [String]
183 flagsFromCabal distPref = do
184 lbi <- getPersistBuildConfig distPref
185 let pd = localPkgDescr lbi
186 case componentNameTargets' pd lbi (CLibName LMainLibName) of
187 [target] ->
188 let clbi = targetCLBI target
189 CLib lib = getComponent pd (componentLocalName clbi)
190 bi = libBuildInfo lib
191 odir = buildDir lbi
192 opts = componentGhcOptions V.normal lbi bi clbi odir
193 in return $ renderGhcOptions (compiler lbi) (hostPlatform lbi) opts
194 [] -> error "no library"
195 _ -> error "more libraries than we know how to handle"
196
197 ----------------------------------------------------------------
198 --- LOADING HASKELL SOURCE
199 --- (these bits actually run the compiler and produce abstract syntax)
200
201 safeLoad :: LoadHowMuch -> Ghc SuccessFlag
202 -- like GHC.load, but does not stop process on exception
203 safeLoad mode = do
204 _dflags <- getSessionDynFlags
205 ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $
206 handleSourceError (\e -> printException e >> return Failed) $
207 load mode
208
209
210 targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()
211 -- load a list of targets
212 targetsAtOneGo hsfiles handles = do
213 targets <- mapM (\f -> guessTarget f Nothing) hsfiles
214 setTargets targets
215 modgraph <- depanal [] False
216 let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
217 graphData mods handles
218
219 fileTarget :: FileName -> Target
220 fileTarget filename = Target (TargetFile filename Nothing) True Nothing
221
222 ---------------------------------------------------------------
223 ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
224
225 graphData :: [ModSummary] -> (Maybe Handle, Maybe Handle) -> Ghc ()
226 graphData mss handles = do
227 mapM_ foundthings mss
228 where foundthings ms =
229 let filename = msHsFilePath ms
230 modname = moduleName $ ms_mod ms
231 in handleSourceError (\e -> do
232 printException e
233 liftIO $ exitWith (ExitFailure 1)) $
234 do liftIO $ putStrLn ("loading " ++ filename)
235 mod <- loadModule =<< typecheckModule =<< parseModule ms
236 case mod of
237 _ | isBootSummary ms -> return ()
238 _ | Just s <- renamedSource mod ->
239 liftIO (writeTagsData handles =<< fileData filename modname s)
240 _otherwise ->
241 liftIO $ exitWith (ExitFailure 1)
242
243 fileData :: FileName -> ModuleName -> RenamedSource -> IO FileData
244 fileData filename modname (group, _imports, _lie, _doc) = do
245 -- lie is related to type checking and so is irrelevant
246 -- imports contains import declarations and no definitions
247 -- doc and haddock seem haddock-related; let's hope to ignore them
248 ls <- lines `fmap` readFile filename
249 let line_map = M.fromAscList $ zip [1..] ls
250 line_map' <- evaluate line_map
251 return $ FileData filename (boundValues modname group) line_map'
252
253 boundValues :: ModuleName -> HsGroup GhcRn -> [FoundThing]
254 -- ^Finds all the top-level definitions in a module
255 boundValues mod group =
256 let vals = case hs_valds group of
257 XValBindsLR (NValBinds nest _sigs) ->
258 [ x | (_rec, binds) <- nest
259 , bind <- bagToList binds
260 , x <- boundThings mod bind ]
261 _other -> error "boundValues"
262 tys = [ n | ns <- map (fst . hsLTyClDeclBinders)
263 (hs_tyclds group >>= group_tyclds)
264 , n <- map found ns ]
265 fors = concat $ map forBound (hs_fords group)
266 where forBound lford = case unLoc lford of
267 ForeignImport _ n _ _ -> [found n]
268 ForeignExport { } -> []
269 XForeignDecl { } -> []
270 in vals ++ tys ++ fors
271 where found = foundOfLName mod
272
273 startOfLocated :: HasSrcSpan a => a -> RealSrcLoc
274 startOfLocated lHs = case getLoc lHs of
275 RealSrcSpan l -> realSrcSpanStart l
276 UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan"
277
278 foundOfLName :: ModuleName -> Located Name -> FoundThing
279 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
280
281 boundThings :: ModuleName -> LHsBind GhcRn -> [FoundThing]
282 boundThings modname lbinding =
283 case unLoc lbinding of
284 FunBind { fun_id = id } -> [thing id]
285 PatBind { pat_lhs = lhs } -> patThings lhs []
286 VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
287 AbsBinds { } -> [] -- nothing interesting in a type abstraction
288 PatSynBind _ PSB{ psb_id = id } -> [thing id]
289 PatSynBind _ (XPatSynBind _) -> []
290 XHsBindsLR _ -> []
291 where thing = foundOfLName modname
292 patThings lpat tl =
293 let loc = startOfLocated lpat
294 lid id = FoundThing modname (getOccString id) loc
295 in case unLoc lpat of
296 WildPat _ -> tl
297 VarPat _ (L _ name) -> lid name : tl
298 LazyPat _ p -> patThings p tl
299 AsPat _ id p -> patThings p (thing id : tl)
300 ParPat _ p -> patThings p tl
301 BangPat _ p -> patThings p tl
302 ListPat _ ps -> foldr patThings tl ps
303 TuplePat _ ps _ -> foldr patThings tl ps
304 ConPatIn _ conargs -> conArgs conargs tl
305 ConPatOut{ pat_args = conargs } -> conArgs conargs tl
306 LitPat _ _ -> tl
307 NPat {} -> tl -- form of literal pattern?
308 NPlusKPat _ id _ _ _ _ -> thing id : tl
309 SigPat _ p _ -> patThings p tl
310 _ -> error "boundThings"
311 conArgs (PrefixCon ps) tl = foldr patThings tl ps
312 conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
313 = foldr (\(L _ f) tl' -> patThings (hsRecFieldArg f) tl') tl flds
314 conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
315
316
317 -- stuff for dealing with ctags output format
318
319 writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO ()
320 writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
321 maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
322 maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
323
324 writectagsfile :: Handle -> FileData -> IO ()
325 writectagsfile ctagsfile filedata = do
326 let things = getfoundthings filedata
327 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
328 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
329
330 getfoundthings :: FileData -> [FoundThing]
331 getfoundthings (FileData _filename things _src_lines) = things
332
333 dumpthing :: Bool -> FoundThing -> String
334 dumpthing showmod (FoundThing modname name loc) =
335 fullname ++ "\t" ++ filename ++ "\t" ++ (show line)
336 where line = srcLocLine loc
337 filename = unpackFS $ srcLocFile loc
338 fullname = if showmod then moduleNameString modname ++ "." ++ name
339 else name
340
341 -- stuff for dealing with etags output format
342
343 writeetagsfile :: Handle -> FileData -> IO ()
344 writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
345
346 e_dumpfiledata :: FileData -> String
347 e_dumpfiledata (FileData filename things line_map) =
348 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
349 where
350 thingsdump = concat $ map (e_dumpthing line_map) things
351 thingslength = length thingsdump
352
353 e_dumpthing :: Map Int String -> FoundThing -> String
354 e_dumpthing src_lines (FoundThing modname name loc) =
355 tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
356 where tagline n = src_code ++ "\x7f"
357 ++ n ++ "\x01"
358 ++ (show line) ++ "," ++ (show $ column) ++ "\n"
359 line = srcLocLine loc
360 column = srcLocCol loc
361 src_code = case M.lookup line src_lines of
362 Just l -> take (column + length name) l
363 Nothing -> --trace (show ("not found: ", moduleNameString modname, name, line, column))
364 name