+{-# OPTIONS_GHC -XCPP -XPatternGuards -Wall #-}
module Main where
+
+import GHC hiding (flags)
+import HscTypes ( isBootSummary )
+import BasicTypes
+import Digraph ( flattenSCCs )
+import DriverPhases ( isHaskellSrcFilename )
+import HscTypes ( msHsFilePath )
+import Name ( getOccString )
+import ErrUtils ( printBagOfErrors )
+import DynFlags ( defaultDynFlags )
+import SrcLoc
import Bag
-import Char
-import DynFlags(GhcMode, defaultDynFlags)
+import Util ( handle, handleDyn )
import FastString
-import GHC
-import HscTypes (msHsFilePath)
-import List
-import IO
-import Name
-import Outputable
-import SrcLoc
+
+import Prelude hiding (mapM)
+import Control.Monad hiding (mapM)
import System.Environment
import System.Console.GetOpt
import System.Exit
-
+import Data.Char
+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
-- We generate both CTAGS and ETAGS format tags files
-- The former is for use in most sensible editors, while EMACS uses ETAGS
-{-
-placateGhc :: IO ()
-placateGhc = defaultErrorHandler defaultDynFlags $ do
- GHC.init (Just "/usr/local/lib/ghc-6.5") -- or your build tree!
- s <- newSession mode
--}
+----------------------------------
+---- 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)
+data FoundThing = FoundThing ModuleName ThingName SrcLoc
+
+-- Data we have obtained from a file (list of things we found)
+data FileData = FileData FileName [FoundThing]
+--- invariant (not checked): every found thing has a source location in that file?
+
+
+------------------------------
+-------- MAIN PROGRAM --------
main :: IO ()
main = do
"Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
args <- getArgs
let (ghcArgs, ourArgs, unbalanced) = splitArgs args
- let (modes, filenames, errs) = getOpt Permute options ourArgs
- if unbalanced || errs /= [] || elem Help modes || filenames == []
+ 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 ()
- let mode = getMode (Append `delete` modes)
- let openFileMode = if elem Append modes
- then AppendMode
- else WriteMode
- GHC.init (Just "/usr/local/lib/ghc-6.5")
- GHC.defaultErrorHandler defaultDynFlags $ do
- session <- newSession JustTypecheck
- print "created a session"
- flags <- getSessionDynFlags session
- (pflags, _) <- parseDynamicFlags flags ghcArgs
- let flags = pflags { hscTarget = HscNothing }
- GHC.defaultCleanupHandler flags $ do
- flags <- initPackages flags
- setSessionDynFlags session flags
- setTargets session (map fileTarget filenames)
- print "set targets"
- success <- load session LoadAllTargets --- bring module graph up to date
- filedata <- case success of
- Failed -> do { putStr "Load failed"; exitWith (ExitFailure 2) }
- Succeeded -> do
- print "loaded all targets"
- graph <- getModuleGraph session
- print "got modules graph"
- graphData session graph
- if mode == BothTags || mode == CTags
- then do
- ctagsfile <- openFile "tags" openFileMode
- writectagsfile ctagsfile filedata
- hClose ctagsfile
- else return ()
- if mode == BothTags || mode == ETags
- then do
- etagsfile <- openFile "TAGS" openFileMode
- writeetagsfile etagsfile filedata
- hClose etagsfile
- else return ()
-
--- | getMode takes a list of modes and extract the mode with the
--- highest precedence. These are as follows: Both, CTags, ETags
--- The default case is Both.
-getMode :: [Mode] -> Mode
-getMode [] = BothTags
-getMode [x] = x
-getMode (x:xs) = max x (getMode xs)
+ let modes = getMode flags
+ let openFileMode = if elem FlagAppend flags
+ then AppendMode
+ else WriteMode
+ 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
+
+ GHC.defaultErrorHandler defaultDynFlags $ do
+ session <- newSession (Just ghc_topdir)
+ dflags <- getSessionDynFlags session
+ (pflags, _) <- parseDynamicFlags dflags{ verbosity=1 } ghcArgs
+ let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
+ GHC.defaultCleanupHandler dflags2 $ do
+
+ setSessionDynFlags session dflags2
+ targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl)
+ mapM_ (mapM hClose) [ctags_hdl, etags_hdl]
+
+----------------------------------------------
+---------- ARGUMENT PROCESSING --------------
+
+data Flag
+ = FlagETags
+ | FlagCTags
+ | FlagBoth
+ | FlagAppend
+ | FlagHelp
+ | FlagTopDir FilePath
+ deriving (Ord, Eq, Show)
+ -- ^Represents options passed to the program
+
+data Mode = ETags | CTags deriving Eq
+
+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 _ = []
splitArgs :: [String] -> ([String], [String], Bool)
--- pull out arguments between -- for GHC
+-- ^Pull out arguments between -- for GHC
splitArgs args = split [] [] False args
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)
-data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
-
-options :: [OptDescr Mode]
-options = [ Option "c" ["ctags"]
- (NoArg CTags) "generate CTAGS file (ctags)"
+options :: [OptDescr Flag]
+-- supports getopt
+options = [ Option "" ["topdir"]
+ (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
+ , Option "c" ["ctags"]
+ (NoArg FlagCTags) "generate CTAGS file (ctags)"
, Option "e" ["etags"]
- (NoArg ETags) "generate ETAGS file (etags)"
+ (NoArg FlagETags) "generate ETAGS file (etags)"
, Option "b" ["both"]
- (NoArg BothTags) ("generate both CTAGS and ETAGS")
+ (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
, Option "a" ["append"]
- (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
- , Option "h" ["help"] (NoArg Help) "This help"
+ (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
+ , Option "h" ["help"] (NoArg FlagHelp) "This help"
]
-type FileName = String
-
-type ThingName = String
-
--- The position of a token or definition
-data Pos = Pos
- FileName -- file name
- Int -- line number
- Int -- token number
- String -- string that makes up that line
- deriving Show
-
-srcLocToPos :: SrcLoc -> Pos
-srcLocToPos loc =
- Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus"
-
--- A definition we have found
-data FoundThing = FoundThing ThingName Pos
- deriving Show
-
--- Data we have obtained from a file
-data FileData = FileData FileName [FoundThing]
-
-data Token = Token String Pos
- deriving Show
-
-
--- stuff for dealing with ctags output format
-
-writectagsfile :: Handle -> [FileData] -> IO ()
-writectagsfile ctagsfile filedata = do
- let things = concat $ map getfoundthings filedata
- mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
-
-getfoundthings :: FileData -> [FoundThing]
-getfoundthings (FileData filename things) = things
-dumpthing :: FoundThing -> String
-dumpthing (FoundThing name (Pos filename line _ _)) =
- name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
+----------------------------------------------------------------
+--- LOADING HASKELL SOURCE
+--- (these bits actually run the compiler and produce abstract syntax)
+safeLoad :: Session -> LoadHowMuch -> IO 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
--- stuff for dealing with etags output format
-writeetagsfile :: Handle -> [FileData] -> IO ()
-writeetagsfile etagsfile filedata = do
- mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
-
-e_dumpfiledata :: FileData -> String
-e_dumpfiledata (FileData filename things) =
- "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
- where
- thingsdump = concat $ map e_dumpthing things
- thingslength = length thingsdump
-
-e_dumpthing :: FoundThing -> String
-e_dumpthing (FoundThing name (Pos filename line token fullline)) =
- ---- (concat $ take (token + 1) $ spacedwords fullline)
- name
- ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
-
-
--- like "words", but keeping the whitespace, and so letting us build
--- accurate prefixes
-
-spacedwords :: String -> [String]
-spacedwords [] = []
-spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
- where
- (blanks,rest) = span Char.isSpace xs
- (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
-
-
--- Find the definitions in a file
-
-modsummary :: ModuleGraph -> FileName -> Maybe ModSummary
-modsummary graph n =
- List.find matches graph
- where matches ms = n == msHsFilePath ms
-
-modname :: ModSummary -> ModuleName
-modname summary = moduleName $ ms_mod $ summary
+targetsAtOneGo :: Session -> [FileName] -> (Maybe Handle, Maybe Handle) -> IO ()
+-- load a list of targets
+targetsAtOneGo session hsfiles handles = do
+ targets <- mapM (\f -> guessTarget f Nothing) hsfiles
+ setTargets session targets
+ mb_modgraph <- depanal session [] False
+ case mb_modgraph of
+ Nothing -> exitWith (ExitFailure 1)
+ Just modgraph -> do
+ let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
+ graphData session mods handles
fileTarget :: FileName -> Target
fileTarget filename = Target (TargetFile filename Nothing) Nothing
-graphData :: Session -> ModuleGraph -> IO [FileData]
-graphData session graph =
- mapM foundthings graph
+---------------------------------------------------------------
+----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
+
+graphData :: Session -> ModuleGraph -> (Maybe Handle, Maybe Handle) -> IO ()
+graphData session graph handles = do
+ mapM_ foundthings graph
where foundthings ms =
let filename = msHsFilePath ms
- in do mod <- checkModule session (moduleName $ ms_mod ms)
- return $ maybe (FileData filename []) id $ do
- m <- mod
- s <- renamedSource m
- return $ fileData filename s
-
-fileData :: FileName -> RenamedSource -> FileData
-fileData filename (group, imports, lie) =
+ modname = moduleName $ ms_mod ms
+ in do putStrLn ("loading " ++ filename)
+ mb_mod <- checkAndLoadModule session ms False
+ case mb_mod of
+ _ | isBootSummary ms -> return ()
+ Just mod | Just s <- renamedSource mod ->
+ writeTagsData handles (fileData filename modname s)
+ _otherwise ->
+ exitWith (ExitFailure 1)
+
+fileData :: FileName -> ModuleName -> RenamedSource -> FileData
+fileData filename modname (group, _imports, _lie, _doc, _haddock) =
-- lie is related to type checking and so is irrelevant
-- imports contains import declarations and no definitions
- FileData filename (boundValues group)
+ -- doc and haddock seem haddock-related; let's hope to ignore them
+ FileData filename (boundValues modname group)
-boundValues :: HsGroup Name -> [FoundThing]
-boundValues group =
+boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
+-- ^Finds all the top-level definitions in a module
+boundValues mod group =
let vals = case hs_valds group of
- ValBindsOut nest sigs ->
- [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
+ 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 } -> [foundOfLName n]
+ ForeignType { tcdLName = n } -> [found n]
TyData { tcdLName = tycon, tcdCons = cons } ->
dataNames tycon cons
- TySynonym { tcdLName = n } -> [foundOfLName n]
- ClassDecl { tcdLName = n } -> [foundOfLName n]
+ 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 _ _ -> [foundOfLName n]
+ ForeignImport n _ _ -> [found n]
ForeignExport { } -> []
in vals ++ tys ++ fors
- where dataNames tycon cons = foundOfLName tycon : map conName cons
- conName td = foundOfLName $ con_name $ unLoc td
+ where dataNames tycon cons = found tycon : map conName cons
+ conName td = found $ con_name $ unLoc td
+ found = foundOfLName mod
+
+startOfLocated :: Located a -> SrcLoc
+startOfLocated lHs = srcSpanStart $ getLoc lHs
+
+foundOfLName :: ModuleName -> Located Name -> FoundThing
+foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
+
+boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
+boundThings modname lbinding =
+ 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)]
+ AbsBinds { } -> [] -- nothing interesting in a type abstraction
+ 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
+ VarPat name -> lid name : tl
+ VarPatOut name _ -> lid name : tl -- XXX need help here
+ LazyPat p -> patThings p tl
+ AsPat id p -> patThings p (thing id : tl)
+ ParPat p -> patThings p tl
+ BangPat p -> patThings p tl
+ ListPat ps _ -> foldr patThings tl ps
+ TuplePat ps _ _ -> foldr patThings tl ps
+ PArrPat ps _ -> foldr patThings tl ps
+ ConPatIn _ conargs -> conArgs conargs tl
+ ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
+ LitPat _ -> tl
+#if __GLASGOW_HASKELL__ > 608
+ NPat _ _ _ -> tl -- form of literal pattern?
+#else
+ NPat _ _ _ _ -> tl -- form of literal pattern?
+#endif
+ NPlusKPat id _ _ _ -> thing id : tl
+ 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
+ conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
+
+
+-- 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
+
+writectagsfile :: Handle -> FileData -> IO ()
+writectagsfile ctagsfile filedata = do
+ let things = getfoundthings filedata
+ mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
+ mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things
-posOfLocated :: Located a -> Pos
-posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
+getfoundthings :: FileData -> [FoundThing]
+getfoundthings (FileData _filename things) = things
+
+dumpthing :: Bool -> FoundThing -> String
+dumpthing showmod (FoundThing modname name loc) =
+ fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
+ where line = srcLocLine loc
+ filename = unpackFS $ srcLocFile loc
+ fullname = if showmod then moduleNameString modname ++ "." ++ name
+ else name
-foundOfLName :: Located Name -> FoundThing
-foundOfLName id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
+-- stuff for dealing with etags output format
-boundThings :: LHsBind Name -> [FoundThing]
-boundThings lbinding =
- let thing = foundOfLName
- in case unLoc lbinding of
- FunBind { fun_id = id } -> [thing id]
- PatBind { pat_lhs = lhs } -> panic "Pattern at top level"
- VarBind { var_id = id } -> [FoundThing (getOccString id) (posOfLocated lbinding)]
- AbsBinds { } -> [] -- nothing interesting in a type abstraction
+writeetagsfile :: Handle -> FileData -> IO ()
+writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
+e_dumpfiledata :: FileData -> String
+e_dumpfiledata (FileData filename things) =
+ "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
+ where
+ thingsdump = concat $ map e_dumpthing things
+ thingslength = length thingsdump
+
+e_dumpthing :: FoundThing -> String
+e_dumpthing (FoundThing modname name loc) =
+ tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
+ where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
+ line = srcLocLine loc
projects / ghc-hetmet.git / blobdiff