X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=0bf37dc4005e408893fc4663c9dc5d34b22a9528;hb=8d180b0dd5b3796c96b162464b93ab1cacc3b789;hp=275a2c144e5e444e94f54e0890d25ab6da255d6d;hpb=2f967bd64b5c080c55ad3f915be5d89f6640152f;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 275a2c1..0bf37dc 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -15,36 +15,38 @@ module InteractiveUI ( -- The GHC interface import qualified GHC -import GHC ( Session, verbosity, dopt, DynFlag(..), +import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..), + TargetId(..), mkModule, pprModule, Type, Module, SuccessFlag(..), - TyThing(..), Name, LoadHowMuch(..), - GhcException(..), showGhcException ) + TyThing(..), Name, LoadHowMuch(..), Phase, + GhcException(..), showGhcException, + CheckedModule(..), SrcLoc ) +import PprTyThing import Outputable --- following all needed for :info... ToDo: remove -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), - IfaceConDecl(..), IfaceType, - pprIfaceDeclHead, pprParendIfaceType, - pprIfaceForAllPart, pprIfaceType ) -import FunDeps ( pprFundeps ) -import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import OccName ( OccName, parenSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), defaultFixity ) +-- for createtags (should these come via GHC?) +import Module( moduleUserString ) +import Name( nameSrcLoc, nameModule, nameOccName ) +import OccName( pprOccName ) +import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) -- Other random utilities +import Digraph ( flattenSCCs ) +import BasicTypes ( failed, successIf ) import Panic ( panic, installSignalHandlers ) import Config import StaticFlags ( opt_IgnoreDotGhci ) import Linker ( showLinkerState ) import Util ( removeSpaces, handle, global, toArgs, - looksLikeModuleName, prefixMatch ) + looksLikeModuleName, prefixMatch, sortLe ) #ifndef mingw32_HOST_OS -import Util ( handle ) import System.Posix #if __GLASGOW_HASKELL__ > 504 hiding (getEnv) #endif +#else +import GHC.ConsoleHandler ( flushConsole ) #endif #ifdef USE_READLINE @@ -61,6 +63,7 @@ import Data.Dynamic import Numeric import Data.List import Data.Int ( Int64 ) +import Data.Maybe ( isJust, fromMaybe, catMaybes ) import System.Cmd import System.CPUTime import System.Environment @@ -99,11 +102,14 @@ builtin_commands = [ ("help", keepGoing help), ("?", keepGoing help), ("info", keepGoing info), - ("load", keepGoingPaths loadModule), + ("load", keepGoingPaths loadModule_), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), + ("check", keepGoing checkModule), ("set", keepGoing setCmd), ("show", keepGoing showCmd), + ("etags", keepGoing createETagsFileCmd), + ("ctags", keepGoing createCTagsFileCmd), ("type", keepGoing typeOfExpr), ("kind", keepGoing kindOfType), ("unset", keepGoing unsetOptions), @@ -141,6 +147,8 @@ helpText = " :show modules show the currently loaded modules\n" ++ " :show bindings show the current bindings made at the prompt\n" ++ "\n" ++ + " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ + " :etags [] create tags file for Emacs (defauilt: \"TAGS\")\n" ++ " :type show the type of \n" ++ " :kind show the kind of \n" ++ " :undef undefine user-defined command :\n" ++ @@ -157,7 +165,7 @@ helpText = " (eg. -v2, -fglasgow-exts, etc.)\n" -interactiveUI :: Session -> [FilePath] -> Maybe String -> IO () +interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () interactiveUI session srcs maybe_expr = do -- HACK! If we happen to get into an infinite loop (eg the user @@ -201,7 +209,7 @@ interactiveUI session srcs maybe_expr = do return () -runGHCi :: [FilePath] -> Maybe String -> GHCi () +runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () runGHCi paths maybe_expr = do let read_dot_files = not opt_IgnoreDotGhci @@ -235,9 +243,13 @@ runGHCi paths maybe_expr = do Right hdl -> fileLoop hdl False -- Perform a :load for files given on the GHCi command line - when (not (null paths)) $ - ghciHandle showException $ - loadModule paths + -- When in -e mode, if the load fails then we want to stop + -- immediately rather than going on to evaluate the expression. + when (not (null paths)) $ do + ok <- ghciHandle (\e -> do showException e; return Failed) $ + loadModule paths + when (isJust maybe_expr && failed ok) $ + io (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. @@ -247,6 +259,18 @@ runGHCi paths maybe_expr = do case maybe_expr of Nothing -> +#if defined(mingw32_HOST_OS) + do + -- The win32 Console API mutates the first character of + -- type-ahead when reading from it in a non-buffered manner. Work + -- around this by flushing the input buffer of type-ahead characters, + -- but only if stdin is available. + flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin)) + case flushed of + Left err | isDoesNotExistError err -> return () + | otherwise -> io (ioError err) + Right () -> return () +#endif -- enter the interactive loop interactiveLoop is_tty show_prompt Just expr -> do @@ -261,7 +285,11 @@ runGHCi paths maybe_expr = do interactiveLoop is_tty show_prompt = do -- Ignore ^C exceptions caught here ghciHandleDyn (\e -> case e of - Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt) + Interrupted -> ghciUnblock ( +#if defined(mingw32_HOST_OS) + io (putStrLn "") >> +#endif + interactiveLoop is_tty show_prompt) _other -> return ()) $ do -- read commands from stdin @@ -362,6 +390,11 @@ readlineLoop = do runCommand :: String -> GHCi Bool runCommand c = ghciHandle handler (doCommand c) + where + doCommand (':' : command) = specialCommand command + doCommand stmt + = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) + return False -- This version is for the GHC command-line option -e. The only difference -- from runCommand is that it catches the ExitException exception and @@ -372,6 +405,14 @@ runCommandEval c = ghciHandle handleEval (doCommand c) handleEval e = do showException e io (exitWith (ExitFailure 1)) + doCommand (':' : command) = specialCommand command + doCommand stmt + = do nms <- runStmt stmt + case nms of + Nothing -> io (exitWith (ExitFailure 1)) + -- failure to run the command causes exit(1) for ghc -e. + _ -> finishEvalExpr nms + -- This is the exception handler for exceptions generated by the -- user's code; it normally just prints out the exception. The -- handler must be recursive, in case showing the exception causes @@ -398,29 +439,26 @@ showException (DynException dyn) = showException other_exception = io (putStrLn ("*** Exception: " ++ show other_exception)) -doCommand (':' : command) = specialCommand command -doCommand stmt - = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) - return False - -runStmt :: String -> GHCi [Name] +runStmt :: String -> GHCi (Maybe [Name]) runStmt stmt - | null (filter (not.isSpace) stmt) = return [] + | null (filter (not.isSpace) stmt) = return (Just []) | otherwise = do st <- getGHCiState session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt case result of - GHC.RunFailed -> return [] + GHC.RunFailed -> return Nothing GHC.RunException e -> throw e -- this is caught by runCommand(Eval) - GHC.RunOk names -> return names + GHC.RunOk names -> return (Just names) -- possibly print the type and revert CAFs after evaluating an expression -finishEvalExpr names +finishEvalExpr mb_names = do b <- isOptionSet ShowType session <- getSession - when b (mapM_ (showTypeOfName session) names) + case mb_names of + Nothing -> return () + Just names -> when b (mapM_ (showTypeOfName session) names) flushInterpBuffers io installSignalHandlers @@ -455,9 +493,6 @@ specialCommand str = do foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")") >> return False) -noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments")) - - ----------------------------------------------------------------------------- -- To flush buffers for the *interpreted* computation we need -- to refer to *its* stdout/stderr handles @@ -511,130 +546,32 @@ info s = do { let names = words s ; let exts = dopt Opt_GlasgowExts dflags ; mapM_ (infoThing exts session) names } where - infoThing exts session name - = do { stuff <- io (GHC.getInfo session name) - ; unqual <- io (GHC.getPrintUnqual session) - ; io (putStrLn (showSDocForUser unqual $ - vcat (intersperse (text "") (map (showThing exts) stuff)))) } - -showThing :: Bool -> GHC.GetInfoResult -> SDoc -showThing exts (wanted_str, thing, fixity, src_loc, insts) - = vcat [ showWithLoc src_loc (showDecl exts want_name thing), - show_fixity fixity, - vcat (map show_inst insts)] + infoThing exts session str = io $ do + names <- GHC.parseName session str + let filtered = filterOutChildren names + mb_stuffs <- mapM (GHC.getInfo session) filtered + unqual <- GHC.getPrintUnqual session + putStrLn (showSDocForUser unqual $ + vcat (intersperse (text "") $ + [ pprInfo exts stuff | Just stuff <- mb_stuffs ])) + + -- Filter out names whose parent is also there Good + -- example is '[]', which is both a type and data + -- constructor in the same type +filterOutChildren :: [Name] -> [Name] +filterOutChildren names = filter (not . parent_is_there) names + where parent_is_there n + | Just p <- GHC.nameParent_maybe n = p `elem` names + | otherwise = False + +pprInfo exts (thing, fixity, insts) + = pprTyThingInContextLoc exts thing + $$ show_fixity fixity + $$ vcat (map GHC.pprInstance insts) where - want_name occ = wanted_str == occNameUserString occ - show_fixity fix - | fix == defaultFixity = empty - | otherwise = ppr fix <+> text wanted_str - - show_inst (inst_ty, loc) - = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty) - -showWithLoc :: SrcLoc -> SDoc -> SDoc -showWithLoc loc doc - = hang doc 2 (char '\t' <> show_loc loc) - -- The tab tries to make them line up a bit - where - show_loc loc -- The ppr function for SrcLocs is a bit wonky - | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc - | otherwise = comment <+> ppr loc - comment = ptext SLIT("--") - - --- Now there is rather a lot of goop just to print declarations in a --- civilised way with "..." for the parts we are less interested in. - -showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc -showDecl exts want_name (IfaceForeign {ifName = tc}) - = ppr tc <+> ptext SLIT("is a foreign type") - -showDecl exts want_name (IfaceId {ifName = var, ifType = ty}) - = ppr var <+> dcolon <+> showIfaceType exts ty - -showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) - = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (equals <+> ppr mono_ty) - -showDecl exts want_name (IfaceData {ifName = tycon, - ifTyVars = tyvars, ifCons = condecls}) - = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 2 (add_bars (ppr_trim show_con cs)) - where - show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys, - ifConStricts = strs, ifConFields = flds}) - | want_name tycon || want_name con_name || any want_name flds - = Just (show_guts con_name is_infix tys_w_strs flds) - | otherwise = Nothing - where - tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict) - show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta, - ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs }) - | want_name tycon || want_name con_name - = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau) - | otherwise = Nothing - where - tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict) - pp_tau = foldr add pp_res_ty tys_w_strs - pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys) - add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty - - show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2] - show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys) - show_guts con _ tys flds - = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds)))) - where - show_fld (bty, fld) | want_name tycon || want_name con || want_name fld - = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty) - | otherwise = Nothing - - (pp_nd, context, cs) = case condecls of - IfAbstractTyCon -> (ptext SLIT("data"), [], []) - IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs) - IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs) - IfNewTyCon c -> (ptext SLIT("newtype"), [], [c]) - - add_bars [] = empty - add_bars [c] = equals <+> c - add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs) - - ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty - ppr_str MarkedStrict = char '!' - ppr_str MarkedUnboxed = ptext SLIT("!!") - ppr_str NotMarkedStrict = empty - -showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifSigs = sigs}) - = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars - <+> pprFundeps fds <+> opt_where) - 2 (vcat (ppr_trim show_op sigs)) - where - opt_where | null sigs = empty - | otherwise = ptext SLIT("where") - show_op (IfaceClassOp op dm ty) - | want_name clas || want_name op - = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty) - | otherwise - = Nothing - -showIfaceType :: Bool -> IfaceType -> SDoc -showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls -showIfaceType False ty = ppr ty -- otherwise, print without the foralls - -ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] -ppr_trim show xs - = snd (foldr go (False, []) xs) - where - go x (eliding, so_far) - | Just doc <- show x = (False, doc : so_far) - | otherwise = if eliding then (True, so_far) - else (True, ptext SLIT("...") : so_far) - -ppr_bndr :: OccName -> SDoc --- Wrap operators in () -ppr_bndr occ = parenSymOcc occ (ppr occ) - + | fix == GHC.defaultFixity = empty + | otherwise = ppr fix <+> ppr (GHC.getName thing) ----------------------------------------------------------------------------- -- Commands @@ -643,7 +580,7 @@ addModule :: [FilePath] -> GHCi () addModule files = do io (revertCAFs) -- always revert CAFs on load/add. files <- mapM expandPath files - targets <- mapM (io . GHC.guessTarget) files + targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files session <- getSession io (mapM_ (GHC.addTarget session) targets) ok <- io (GHC.load session LoadAllTargets) @@ -657,7 +594,7 @@ changeDirectory dir = do io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) - setContextAfterLoad [] + setContextAfterLoad session [] io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -705,10 +642,13 @@ undefineMacro macro_name = do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) -loadModule :: [FilePath] -> GHCi () +loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) -loadModule' :: [FilePath] -> GHCi () +loadModule_ :: [FilePath] -> GHCi () +loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () + +loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule' files = do session <- getSession @@ -717,8 +657,10 @@ loadModule' files = do io (GHC.load session LoadAllTargets) -- expand tildes - files <- mapM expandPath files - targets <- io (mapM GHC.guessTarget files) + let (filenames, phases) = unzip files + exp_filenames <- mapM expandPath filenames + let files' = zip exp_filenames phases + targets <- io (mapM (uncurry GHC.guessTarget) files') -- NOTE: we used to do the dependency anal first, so that if it -- fails we didn't throw away the current set of modules. This would @@ -728,7 +670,25 @@ loadModule' files = do io (GHC.setTargets session targets) ok <- io (GHC.load session LoadAllTargets) afterLoad ok session + return ok +checkModule :: String -> GHCi () +checkModule m = do + let modl = mkModule m + session <- getSession + result <- io (GHC.checkModule session modl) + case result of + Nothing -> io $ putStrLn "Nothing" + Just r -> io $ putStrLn (showSDoc ( + case checkedModuleInfo r of + Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> + let + (local,global) = partition ((== modl) . GHC.nameModule) scope + in + (text "global names: " <+> ppr global) $$ + (text "local names: " <+> ppr local) + _ -> empty)) + afterLoad (successIf (isJust result)) session reloadModule :: String -> GHCi () reloadModule "" = do @@ -745,19 +705,39 @@ reloadModule m = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. graph <- io (GHC.getModuleGraph session) - let mods = map GHC.ms_mod graph - mods' <- filterM (io . GHC.isLoaded session) mods - setContextAfterLoad mods' - modulesLoadedMsg ok mods' + graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph + setContextAfterLoad session graph' + modulesLoadedMsg ok (map GHC.ms_mod graph') -setContextAfterLoad [] = do - session <- getSession +setContextAfterLoad session [] = do io (GHC.setContext session [] [prelude_mod]) -setContextAfterLoad (m:_) = do - session <- getSession - b <- io (GHC.moduleIsInterpreted session m) - if b then io (GHC.setContext session [m] []) - else io (GHC.setContext session [] [m]) +setContextAfterLoad session ms = do + -- load a target if one is available, otherwise load the topmost module. + targets <- io (GHC.getTargets session) + case [ m | Just m <- map (findTarget ms) targets ] of + [] -> + let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in + load_this (last graph') + (m:_) -> + load_this m + where + findTarget ms t + = case filter (`matches` t) ms of + [] -> Nothing + (m:_) -> Just m + + summary `matches` Target (TargetModule m) _ + = GHC.ms_mod summary == m + summary `matches` Target (TargetFile f _) _ + | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' + summary `matches` target + = False + + load_this summary | m <- GHC.ms_mod summary = do + b <- io (GHC.moduleIsInterpreted session m) + if b then io (GHC.setContext session [m] []) + else io (GHC.setContext session [] [prelude_mod,m]) + modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi () modulesLoadedMsg ok mods = do @@ -800,6 +780,117 @@ shellEscape :: String -> GHCi Bool shellEscape str = io (system str >> return False) ----------------------------------------------------------------------------- +-- create tags file for currently loaded modules. + +createETagsFileCmd, createCTagsFileCmd :: String -> GHCi () + +createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags" +createCTagsFileCmd file = ghciCreateTagsFile CTags file + +createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" +createETagsFileCmd file = ghciCreateTagsFile ETags file + +data TagsKind = ETags | CTags + +ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi () +ghciCreateTagsFile kind file = do + session <- getSession + io $ createTagsFile session kind file + +-- ToDo: +-- - remove restriction that all modules must be interpreted +-- (problem: we don't know source locations for entities unless +-- we compiled the module. +-- +-- - extract createTagsFile so it can be used from the command-line +-- (probably need to fix first problem before this is useful). +-- +createTagsFile :: Session -> TagsKind -> FilePath -> IO () +createTagsFile session tagskind tagFile = do + graph <- GHC.getModuleGraph session + let ms = map GHC.ms_mod graph + tagModule m = do + is_interpreted <- GHC.moduleIsInterpreted session m + -- should we just skip these? + when (not is_interpreted) $ + throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted")) + + mbModInfo <- GHC.getModuleInfo session m + let unqual + | Just modinfo <- mbModInfo, + Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual + | otherwise = GHC.alwaysQualify + + case mbModInfo of + Just modInfo -> return $! listTags unqual modInfo + _ -> return [] + + mtags <- mapM tagModule ms + either_res <- collateAndWriteTags tagskind tagFile $ concat mtags + case either_res of + Left e -> hPutStrLn stderr $ ioeGetErrorString e + Right _ -> return () + +listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo] +listTags unqual modInfo = + [ tagInfo unqual name loc + | name <- GHC.modInfoExports modInfo + , let loc = nameSrcLoc name + , isGoodSrcLoc loc + ] + +type TagInfo = (String -- tag name + ,String -- file name + ,Int -- line number + ,Int -- column number + ) + +-- get tag info, for later translation into Vim or Emacs style +tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo +tagInfo unqual name loc + = ( showSDocForUser unqual $ pprOccName (nameOccName name) + , showSDocForUser unqual $ ftext (srcLocFile loc) + , srcLocLine loc + , srcLocCol loc + ) + +collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ()) +collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al + let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos + IO.try (writeFile file tags) +collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs + let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2 + groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos + tagGroups <- mapM tagFileGroup groups + IO.try (writeFile file $ concat tagGroups) + where + tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??") + tagFileGroup group@((_,fileName,_,_):_) = do + file <- readFile fileName -- need to get additional info from sources.. + let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2 + sortedGroup = sortLe byLine group + tags = unlines $ perFile sortedGroup 1 0 $ lines file + return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags + perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count = + perFile (tagInfo:tags) (count+1) (pos+length line) lines + perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count = + showETag tagInfo line pos : perFile tags count pos lines + perFile tags count pos lines = [] + +-- simple ctags format, for Vim et al +showTag :: TagInfo -> String +showTag (tag,file,lineNo,colNo) + = tag ++ "\t" ++ file ++ "\t" ++ show lineNo + +-- etags format, for Emacs/XEmacs +showETag :: TagInfo -> String -> Int -> String +showETag (tag,file,lineNo,colNo) line charPos + = take colNo line ++ tag + ++ "\x7f" ++ tag + ++ "\x01" ++ show lineNo + ++ "," ++ show charPos + +----------------------------------------------------------------------------- -- Browsing a module's contents browseCmd :: String -> GHCi () @@ -822,16 +913,29 @@ browseModule m exports_only = do (as,bs) <- io (GHC.getContext s) io (if exports_only then GHC.setContext s [] [prelude_mod,modl] else GHC.setContext s [modl] []) + unqual <- io (GHC.getPrintUnqual s) io (GHC.setContext s as bs) - things <- io (GHC.browseModule s modl exports_only) - unqual <- io (GHC.getPrintUnqual s) + mb_mod_info <- io $ GHC.getModuleInfo s modl + case mb_mod_info of + Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m)) + Just mod_info -> do + let names + | exports_only = GHC.modInfoExports mod_info + | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info) - dflags <- getDynFlags - let exts = dopt Opt_GlasgowExts dflags - io (putStrLn (showSDocForUser unqual ( - vcat (map (showDecl exts (const True)) things) - ))) + filtered = filterOutChildren names + + things <- io $ mapM (GHC.lookupName s) filtered + + dflags <- getDynFlags + let exts = dopt Opt_GlasgowExts dflags + io (putStrLn (showSDocForUser unqual ( + vcat (map (pprTyThingInContext exts) (catMaybes things)) + ))) + -- ToDo: modInfoInstances currently throws an exception for + -- package modules. When it works, we can do this: + -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) ----------------------------------------------------------------------------- -- Setting the module context