Main.hs 14.3 KB
Newer Older
1
{-# LANGUAGE ScopedTypeVariables #-}
2
module Main where
Simon Marlow's avatar
Simon Marlow committed
3

4
import Prelude hiding ( mod, id, mapM )
5
import GHC
6
--import Packages
7
8
9
10
11
import HscTypes         ( isBootSummary )
import Digraph          ( flattenSCCs )
import DriverPhases     ( isHaskellSrcFilename )
import HscTypes         ( msHsFilePath )
import Name             ( getOccString )
12
--import ErrUtils         ( printBagOfErrors )
13
import Panic            ( panic )
Ian Lynagh's avatar
Ian Lynagh committed
14
import DynFlags         ( defaultFatalMessager, defaultFlushOut )
Simon Marlow's avatar
Simon Marlow committed
15
import Bag
16
import Exception
Simon Marlow's avatar
Simon Marlow committed
17
import FastString
Thomas Schilling's avatar
Thomas Schilling committed
18
import MonadUtils       ( liftIO )
19
import SrcLoc
Simon Marlow's avatar
Simon Marlow committed
20

pcapriotti's avatar
pcapriotti committed
21
import Distribution.Simple.GHC ( componentGhcOptions )
22
import Distribution.Simple.Configure ( getPersistBuildConfig )
pcapriotti's avatar
pcapriotti committed
23
import Distribution.Simple.Program.GHC ( renderGhcOptions )
24
import Distribution.PackageDescription ( library, libBuildInfo )
ian@well-typed.com's avatar
ian@well-typed.com committed
25
import Distribution.Simple.LocalBuildInfo
pcapriotti's avatar
pcapriotti committed
26
import qualified Distribution.Verbosity as V
27

28
import Control.Monad hiding (mapM)
29
30
31
import System.Environment
import System.Console.GetOpt
import System.Exit
Simon Marlow's avatar
Simon Marlow committed
32
import System.IO
33
import Data.List as List hiding ( group )
34
import Data.Traversable (mapM)
35
36
37
38
39
import Data.Map ( Map )
import qualified Data.Map as M

--import UniqFM
--import Debug.Trace
40

41
-- search for definitions of things
42
43
44
45
46
-- we do this by parsing the source and grabbing top-level definitions

-- We generate both CTAGS and ETAGS format tags files
-- The former is for use in most sensible editors, while EMACS uses ETAGS

47
48
49
50
51
52
53
----------------------------------
---- CENTRAL DATA TYPES ----------

type FileName = String
type ThingName = String -- name of a defined entity in a Haskell program

-- A definition we have found (we know its containing module, name, and location)
54
data FoundThing = FoundThing ModuleName ThingName RealSrcLoc
55
56

-- Data we have obtained from a file (list of things we found)
57
data FileData = FileData FileName [FoundThing] (Map Int String)
58
59
60
61
62
--- invariant (not checked): every found thing has a source location in that file?


------------------------------
-------- MAIN PROGRAM --------
63
64
65

main :: IO ()
main = do
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
  progName <- getProgName
  let usageString =
        "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
  args <- getArgs
  let (ghcArgs', ourArgs, unbalanced) = splitArgs args
  let (flags, filenames, errs) = getOpt Permute options ourArgs
  let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames

  let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
                          [] -> ""
                          (x:_) -> x
  mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
        otherfiles
  if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
   then do
     putStr $ unlines errs
     putStr $ usageInfo usageString options
     exitWith (ExitFailure 1)
   else return ()

  ghcArgs <- case [ d | FlagUseCabalConfig d <- flags ] of
               [distPref] -> do
                  cabalOpts <- flagsFromCabal distPref
89
                  return (cabalOpts ++ ghcArgs')
90
91
92
93
94
95
96
               [] ->
                  return ghcArgs'
               _ -> error "Too many --use-cabal-config flags"
  print ghcArgs

  let modes = getMode flags
  let openFileMode = if elem FlagAppend flags
97
98
                     then AppendMode
                     else WriteMode
99
100
101
102
103
104
105
  ctags_hdl <-  if CTags `elem` modes
                     then Just `liftM` openFile "tags" openFileMode
                     else return Nothing
  etags_hdl <- if ETags `elem` modes
                     then Just `liftM` openFile "TAGS" openFileMode
                     else return Nothing

Ian Lynagh's avatar
Ian Lynagh committed
106
  GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $
107
108
109
110
111
112
113
114
115
116
117
    runGhc (Just ghc_topdir) $ do
      --liftIO $ print "starting up session"
      dflags <- getSessionDynFlags
      (pflags, unrec, warns) <- parseDynamicFlags dflags{ verbosity=1 }
                                          (map noLoc ghcArgs)
      unless (null unrec) $
        liftIO $ putStrLn $ "Unrecognised options:\n" ++ show (map unLoc unrec)
      liftIO $ mapM_ putStrLn (map unLoc warns)
      let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
      -- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0
      --                                                        Just m -> sizeUFM m)
118
      _ <- setSessionDynFlags dflags2
119
120
      --liftIO $ print (length pkgs)

121
122
      targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
      mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
123
124
125
126

----------------------------------------------
----------  ARGUMENT PROCESSING --------------

Simon Marlow's avatar
Simon Marlow committed
127
128
129
130
131
132
133
data Flag
   = FlagETags
   | FlagCTags
   | FlagBoth
   | FlagAppend
   | FlagHelp
   | FlagTopDir FilePath
134
135
   | FlagUseCabalConfig FilePath
   | FlagFilesFromCabal
Simon Marlow's avatar
Simon Marlow committed
136
  deriving (Ord, Eq, Show)
137
  -- ^Represents options passed to the program
138

Simon Marlow's avatar
Simon Marlow committed
139
data Mode = ETags | CTags deriving Eq
140

Simon Marlow's avatar
Simon Marlow committed
141
142
143
144
145
146
147
148
149
150
getMode :: [Flag] -> [Mode]
getMode fs = go (concatMap modeLike fs)
 where go []     = [ETags,CTags]
       go [x]    = [x]
       go more   = nub more

       modeLike FlagETags = [ETags]
       modeLike FlagCTags = [CTags]
       modeLike FlagBoth  = [ETags,CTags]
       modeLike _         = []
151

152
splitArgs :: [String] -> ([String], [String], Bool)
153
-- ^Pull out arguments between -- for GHC
154
splitArgs args0 = split [] [] False args0
155
156
157
158
    where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
          split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
          split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)

Simon Marlow's avatar
Simon Marlow committed
159
options :: [OptDescr Flag]
160
-- supports getopt
161
options = [ Option "" ["topdir"]
Simon Marlow's avatar
Simon Marlow committed
162
163
            (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
          , Option "c" ["ctags"]
164
165
166
167
168
169
170
            (NoArg FlagCTags) "generate CTAGS file (ctags)"
          , Option "e" ["etags"]
            (NoArg FlagETags) "generate ETAGS file (etags)"
          , Option "b" ["both"]
            (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
          , Option "a" ["append"]
            (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
171
172
173
174
          , Option "" ["use-cabal-config"]
            (ReqArg FlagUseCabalConfig "DIR") "use local cabal configuration from dist dir"
          , Option "" ["files-from-cabal"]
            (NoArg FlagFilesFromCabal) "use files from cabal"
175
176
          , Option "h" ["help"] (NoArg FlagHelp) "This help"
          ]
177

178
179
180
181
flagsFromCabal :: FilePath -> IO [String]
flagsFromCabal distPref = do
  lbi <- getPersistBuildConfig distPref
  let pd = localPkgDescr lbi
ian@well-typed.com's avatar
ian@well-typed.com committed
182
183
184
185
186
      findLibraryConfig []                         = Nothing
      findLibraryConfig ((CLibName, clbi, _) :  _) = Just clbi
      findLibraryConfig (_                   : xs) = findLibraryConfig xs
      mLibraryConfig = findLibraryConfig (componentsConfigs lbi)
  case (library pd, mLibraryConfig) of
187
    (Just lib, Just clbi) ->
188
189
      let bi = libBuildInfo lib
          odir = buildDir lbi
pcapriotti's avatar
pcapriotti committed
190
          opts = componentGhcOptions V.normal lbi bi clbi odir
191
      in return $ renderGhcOptions (compiler lbi) (hostPlatform lbi) opts
192
    _ -> error "no library"
193

194
195
196
----------------------------------------------------------------
--- LOADING HASKELL SOURCE
--- (these bits actually run the compiler and produce abstract syntax)
197

Thomas Schilling's avatar
Thomas Schilling committed
198
safeLoad :: LoadHowMuch -> Ghc SuccessFlag
199
-- like GHC.load, but does not stop process on exception
Thomas Schilling's avatar
Thomas Schilling committed
200
safeLoad mode = do
201
  _dflags <- getSessionDynFlags
Thomas Schilling's avatar
Thomas Schilling committed
202
  ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $
Simon Marlow's avatar
Simon Marlow committed
203
    handleSourceError (\e -> printException e >> return Failed) $
Thomas Schilling's avatar
Thomas Schilling committed
204
      load mode
205
206


Thomas Schilling's avatar
Thomas Schilling committed
207
targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()
208
-- load a list of targets
Thomas Schilling's avatar
Thomas Schilling committed
209
targetsAtOneGo hsfiles handles = do
Simon Marlow's avatar
Simon Marlow committed
210
  targets <- mapM (\f -> guessTarget f Nothing) hsfiles
Thomas Schilling's avatar
Thomas Schilling committed
211
212
213
214
  setTargets targets
  modgraph <- depanal [] False
  let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
  graphData mods handles
215

216
fileTarget :: FileName -> Target
Thomas Schilling's avatar
Thomas Schilling committed
217
fileTarget filename = Target (TargetFile filename Nothing) True Nothing
218

219
220
221
---------------------------------------------------------------
----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----

Thomas Schilling's avatar
Thomas Schilling committed
222
223
graphData :: ModuleGraph -> (Maybe Handle, Maybe Handle) -> Ghc ()
graphData graph handles = do
Simon Marlow's avatar
Simon Marlow committed
224
    mapM_ foundthings graph
225
226
227
    where foundthings ms =
              let filename = msHsFilePath ms
                  modname = moduleName $ ms_mod ms
228
              in handleSourceError (\e -> do
Simon Marlow's avatar
Simon Marlow committed
229
                                       printException e
230
231
                                       liftIO $ exitWith (ExitFailure 1)) $
                  do liftIO $ putStrLn ("loading " ++ filename)
Thomas Schilling's avatar
Thomas Schilling committed
232
233
                     mod <- loadModule =<< typecheckModule =<< parseModule ms
                     case mod of
234
                       _ | isBootSummary ms -> return ()
Thomas Schilling's avatar
Thomas Schilling committed
235
                       _ | Just s <- renamedSource mod ->
236
                         liftIO (writeTagsData handles =<< fileData filename modname s)
237
                       _otherwise ->
Thomas Schilling's avatar
Thomas Schilling committed
238
                         liftIO $ exitWith (ExitFailure 1)
239

240
fileData :: FileName -> ModuleName -> RenamedSource -> IO FileData
241
fileData filename modname (group, _imports, _lie, _doc) = do
242
243
    -- lie is related to type checking and so is irrelevant
    -- imports contains import declarations and no definitions
244
    -- doc and haddock seem haddock-related; let's hope to ignore them
245
246
    ls <- lines `fmap` readFile filename
    let line_map = M.fromAscList $ zip [1..] ls
247
248
    line_map' <- evaluate line_map
    return $ FileData filename (boundValues modname group) line_map'
249

250
boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
251
-- ^Finds all the top-level definitions in a module
252
boundValues mod group =
253
  let vals = case hs_valds group of
254
               ValBindsOut nest _sigs ->
255
                   [ x | (_rec, binds) <- nest
256
                       , bind <- bagToList binds
257
                       , x <- boundThings mod bind ]
258
               _other -> error "boundValues"
Adam Gundry's avatar
Adam Gundry committed
259
      tys = [ n | ns <- map (fst . hsLTyClDeclBinders) (tyClGroupConcat (hs_tyclds group))
260
                , n <- map found ns ]
261
262
      fors = concat $ map forBound (hs_fords group)
             where forBound lford = case unLoc lford of
263
                                      ForeignImport n _ _ _ -> [found n]
264
265
                                      ForeignExport { } -> []
  in vals ++ tys ++ fors
266
  where found = foundOfLName mod
267

268
269
270
271
startOfLocated :: Located a -> RealSrcLoc
startOfLocated lHs = case getLoc lHs of
                     RealSrcSpan l -> realSrcSpanStart l
                     UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan"
272

273
274
foundOfLName :: ModuleName -> Located Name -> FoundThing
foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
275

276
boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
277
boundThings modname lbinding =
278
279
280
281
  case unLoc lbinding of
    FunBind { fun_id = id } -> [thing id]
    PatBind { pat_lhs = lhs } -> patThings lhs []
    VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
282
283
    AbsBinds { }    -> [] -- nothing interesting in a type abstraction
    AbsBindsSig { } -> []
284
    PatSynBind PSB{ psb_id = id } -> [thing id]
285
286
287
288
289
290
  where thing = foundOfLName modname
        patThings lpat tl =
          let loc = startOfLocated lpat
              lid id = FoundThing modname (getOccString id) loc
          in case unLoc lpat of
               WildPat _ -> tl
291
               VarPat (L _ name) -> lid name : tl
292
293
294
295
               LazyPat p -> patThings p tl
               AsPat id p -> patThings p (thing id : tl)
               ParPat p -> patThings p tl
               BangPat p -> patThings p tl
Simon Peyton Jones's avatar
Simon Peyton Jones committed
296
               ListPat ps _ _ -> foldr patThings tl ps
297
298
299
               TuplePat ps _ _ -> foldr patThings tl ps
               PArrPat ps _ -> foldr patThings tl ps
               ConPatIn _ conargs -> conArgs conargs tl
Gergő Érdi's avatar
Gergő Érdi committed
300
               ConPatOut{ pat_args = conargs } -> conArgs conargs tl
301
               LitPat _ -> tl
302
303
               NPat {} -> tl -- form of literal pattern?
               NPlusKPat id _ _ _ _ _ -> thing id : tl
304
305
               SigPatIn p _ -> patThings p tl
               SigPatOut p _ -> patThings p tl
306
               _ -> error "boundThings"
307
        conArgs (PrefixCon ps) tl = foldr patThings tl ps
308
        conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
309
             = foldr (\(L _ f) tl' -> patThings (hsRecFieldArg f) tl') tl flds
310
        conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
311
312
313
314


-- stuff for dealing with ctags output format

315
writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO ()
316
writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
Simon Marlow's avatar
Simon Marlow committed
317
318
319
320
  maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
  maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl

writectagsfile :: Handle -> FileData -> IO ()
321
writectagsfile ctagsfile filedata = do
322
323
324
        let things = getfoundthings filedata
        mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
        mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True  x) things
325
326

getfoundthings :: FileData -> [FoundThing]
327
getfoundthings (FileData _filename things _src_lines) = things
328
329
330

dumpthing :: Bool -> FoundThing -> String
dumpthing showmod (FoundThing modname name loc) =
331
        fullname ++ "\t" ++ filename ++ "\t" ++ (show line)
332
333
334
335
336
337
338
    where line = srcLocLine loc
          filename = unpackFS $ srcLocFile loc
          fullname = if showmod then moduleNameString modname ++ "." ++ name
                     else name

-- stuff for dealing with etags output format

Simon Marlow's avatar
Simon Marlow committed
339
340
writeetagsfile :: Handle -> FileData -> IO ()
writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
341
342

e_dumpfiledata :: FileData -> String
343
e_dumpfiledata (FileData filename things line_map) =
344
345
346
347
        "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
        where
                thingsdump = concat $ map (e_dumpthing line_map) things
                thingslength = length thingsdump
348

349
350
e_dumpthing :: Map Int String -> FoundThing -> String
e_dumpthing src_lines (FoundThing modname name loc) =
351
    tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
352
353
354
    where tagline n = src_code ++ "\x7f"
                      ++ n ++ "\x01"
                      ++ (show line) ++ "," ++ (show $ column) ++ "\n"
355
          line = srcLocLine loc
356
357
358
          column = srcLocCol loc
          src_code = case M.lookup line src_lines of
                       Just l -> take (column + length name) l
359
                       Nothing -> --trace (show ("not found: ", moduleNameString modname, name, line, column))
360
                                  name