-{-# OPTIONS_GHC -XCPP #-}
+{-# OPTIONS_GHC -XCPP -XPatternGuards -XScopedTypeVariables -Wall #-}
module Main where
-import GHC
+import GHC hiding (flags)
+import HscTypes ( isBootSummary )
import BasicTypes
-import Digraph ( flattenSCCs )
-import DriverPhases ( isHaskellSrcFilename )
-import HscTypes (msHsFilePath)
-import Name
-import Outputable
-import ErrUtils ( printBagOfErrors )
-import DynFlags(GhcMode, defaultDynFlags)
+import Digraph ( flattenSCCs )
+import DriverPhases ( isHaskellSrcFilename )
+import HscTypes ( msHsFilePath )
+import Name ( getOccString )
+import ErrUtils ( printBagOfErrors )
+import DynFlags ( defaultDynFlags )
import SrcLoc
import Bag
-import Util ( handle, handleDyn )
+import Exception -- ( ghandle )
import FastString
+import MonadUtils ( liftIO )
-import Control.Monad
+import Prelude hiding (mapM)
+import Control.Monad hiding (mapM)
import System.Environment
import System.Console.GetOpt
import System.Exit
import System.IO
import Data.List as List
import Data.Maybe
+import Data.Traversable (mapM)
-- search for definitions of things
-- we do this by parsing the source and grabbing top-level definitions
then Just `liftM` openFile "TAGS" openFileMode
else return Nothing
- GHC.defaultErrorHandler defaultDynFlags $ do
- session <- newSession (Just ghc_topdir)
- flags <- getSessionDynFlags session
- (pflags, _) <- parseDynamicFlags flags{ verbosity=1 } ghcArgs
- let flags = pflags { hscTarget = HscNothing } -- don't generate anything
- GHC.defaultCleanupHandler flags $ do
+ GHC.defaultErrorHandler defaultDynFlags $
+ runGhc (Just ghc_topdir) $ do
+ dflags <- getSessionDynFlags
+ (pflags, _, _) <- parseDynamicFlags dflags{ verbosity=1 } (map noLoc ghcArgs)
+ let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
+ GHC.defaultCleanupHandler dflags2 $ do
- setSessionDynFlags session flags
- targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl)
+ setSessionDynFlags dflags2
+ targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
+ mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
----------------------------------------------
---------- ARGUMENT PROCESSING --------------
--- LOADING HASKELL SOURCE
--- (these bits actually run the compiler and produce abstract syntax)
-safeLoad :: Session -> LoadHowMuch -> IO SuccessFlag
+safeLoad :: LoadHowMuch -> Ghc SuccessFlag
-- like GHC.load, but does not stop process on exception
-safeLoad session mode = do
- dflags <- getSessionDynFlags session
- handle (\exception -> return Failed ) $
- handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
- return Failed) $ load session mode
+safeLoad mode = do
+ dflags <- getSessionDynFlags
+ ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $
+ handleSourceError (\e -> printExceptionAndWarnings e >> return Failed) $
+ load mode
-targetsAtOneGo :: Session -> [FileName] -> (Maybe Handle, Maybe Handle) -> IO ()
+targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()
-- load a list of targets
-targetsAtOneGo session hsfiles handles = do
+targetsAtOneGo hsfiles handles = do
targets <- mapM (\f -> guessTarget f Nothing) hsfiles
- setTargets session targets
- putStrLn $ "Load it all:"
- flag <- load session LoadAllTargets
- when (failed flag) $ exitWith (ExitFailure 1)
- modgraph <- getModuleGraph session
+ setTargets targets
+ modgraph <- depanal [] False
let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
- graphData session mods handles
-
- where targetInfo [hs] = "target " ++ hs
- targetInfo hss = show (length hss) ++ " targets at one go"
+ graphData mods handles
fileTarget :: FileName -> Target
-fileTarget filename = Target (TargetFile filename Nothing) Nothing
+fileTarget filename = Target (TargetFile filename Nothing) True Nothing
---------------------------------------------------------------
----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
-graphData :: Session -> ModuleGraph -> (Maybe Handle, Maybe Handle) -> IO ()
-graphData session graph handles = do
+graphData :: ModuleGraph -> (Maybe Handle, Maybe Handle) -> Ghc ()
+graphData graph handles = do
mapM_ foundthings graph
where foundthings ms =
let filename = msHsFilePath ms
modname = moduleName $ ms_mod ms
- in do mod <- checkModule session modname False
- let fd = maybe (FileData filename []) id $ do
- m <- mod
- s <- renamedSource m
- return $ fileData filename modname s
- writeTagsData handles fd
+ in do liftIO $ putStrLn ("loading " ++ filename)
+ mod <- loadModule =<< typecheckModule =<< parseModule ms
+ case mod of
+ _ | isBootSummary ms -> return ()
+ _ | Just s <- renamedSource mod ->
+ liftIO $ writeTagsData handles (fileData filename modname s)
+ _otherwise ->
+ liftIO $ exitWith (ExitFailure 1)
fileData :: FileName -> ModuleName -> RenamedSource -> FileData
fileData filename modname (group, _imports, _lie, _doc, _haddock) =
-- ^Finds all the top-level definitions in a module
boundValues mod group =
let vals = case hs_valds group of
- ValBindsOut nest sigs ->
+ ValBindsOut nest _sigs ->
[ x | (_rec, binds) <- nest, bind <- bagToList binds,
x <- boundThings mod bind ]
+ _other -> error "boundValues"
tys = concat $ map tyBound (hs_tyclds group)
where tyBound ltcd = case unLoc ltcd of
ForeignType { tcdLName = n } -> [found n]
dataNames tycon cons
TySynonym { tcdLName = n } -> [found n]
ClassDecl { tcdLName = n } -> [found n]
+ _ -> error "boundValues: tys"
fors = concat $ map forBound (hs_fords group)
where forBound lford = case unLoc lford of
ForeignImport n _ _ -> [found n]
TypePat _ -> tl -- XXX need help here
SigPatIn p _ -> patThings p tl
SigPatOut p _ -> patThings p tl
+ _ -> error "boundThings"
conArgs (PrefixCon ps) tl = foldr patThings tl ps
conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
= foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl flds
-- stuff for dealing with ctags output format
+writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO ()
writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
getfoundthings :: FileData -> [FoundThing]
-getfoundthings (FileData filename things) = things
+getfoundthings (FileData _filename things) = things
dumpthing :: Bool -> FoundThing -> String
dumpthing showmod (FoundThing modname name loc) =