Commit 03b874e7 authored by simonmar's avatar simonmar
Browse files

[project @ 2002-01-24 16:55:35 by simonmar]

Add support for Hugs's :browse (or :b) command.  There are two forms:

	- :b M   (interpreted modules only) shows everything
          defined in M - the types of top-level functions,
	  and definitions of classes and datatypes.

	- :b *M  shows everything exported from module M.
	  Available for both compiled and interpreted modules.

The user interface is subject to change, but for now it is consistent
with the new semantics of the :module command.

The implementation is a little tricky, since for a package module we
have to be sure to slurp in all the required declarations first.
parent d8ef45a3
......@@ -28,6 +28,8 @@ module CompManager (
cmInfoThing, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, [(TyThing,Fixity)])
cmBrowseModule, -- :: CmState -> IO [TyThing]
CmRunResult(..),
cmRunStmt, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, CmRunResult)
......@@ -66,7 +68,8 @@ import DriverPhases
import DriverUtil
import Finder
#ifdef GHCI
import HscMain ( initPersistentCompilerState, hscThing )
import HscMain ( initPersistentCompilerState, hscThing,
hscModuleContents )
#else
import HscMain ( initPersistentCompilerState )
#endif
......@@ -217,11 +220,11 @@ moduleNameToModule hit mn = do
case lookupModuleEnvByName hit mn of
Just iface -> return (mi_module iface)
_not_a_home_module -> do
maybe_stuff <- findModule mn
case maybe_stuff of
Nothing -> throwDyn (CmdLineError ("can't find module `"
++ moduleNameUserString mn ++ "'"))
Just (m,_) -> return m
maybe_stuff <- findModule mn
case maybe_stuff of
Nothing -> throwDyn (CmdLineError ("can't find module `"
++ moduleNameUserString mn ++ "'"))
Just (m,_) -> return m
cmGetContext :: CmState -> IO ([String],[String])
cmGetContext CmState{ic=ic} =
......@@ -261,6 +264,24 @@ cmInfoThing cmstate dflags id
| otherwise = pcs_PIT pcs
#endif
-- ---------------------------------------------------------------------------
-- cmBrowseModule: get all the TyThings defined in a module
#ifdef GHCI
cmBrowseModule :: CmState -> DynFlags -> String -> Bool
-> IO (CmState, [TyThing])
cmBrowseModule cmstate dflags str exports_only = do
let mn = mkModuleName str
mod <- moduleNameToModule hit mn
(pcs1, maybe_ty_things)
<- hscModuleContents dflags hst hit pcs mod exports_only
case maybe_ty_things of
Nothing -> return (cmstate{pcs=pcs1}, [])
Just ty_things -> return (cmstate{pcs=pcs1}, ty_things)
where
CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
#endif
-----------------------------------------------------------------------------
-- cmRunStmt: Run a statement/expr.
......
{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.109 2002/01/23 16:50:49 simonmar Exp $
-- $Id: InteractiveUI.hs,v 1.110 2002/01/24 16:55:36 simonmar Exp $
--
-- GHC Interactive User Interface
--
......@@ -19,6 +19,7 @@ import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) )
import CmLink ( findModuleLinkable_maybe )
import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) )
import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
import MkIface ( ifaceTyThing )
import DriverFlags
import DriverState
......@@ -27,7 +28,7 @@ import Linker
import Finder ( flushPackageCache )
import Util
import Id ( isRecordSelector, recordSelectorFieldLabel,
isDataConWrapId, idName )
isDataConWrapId, isDataConId, idName )
import Class ( className )
import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
import FieldLabel ( fieldLabelTyCon )
......@@ -84,6 +85,7 @@ GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
builtin_commands :: [(String, String -> GHCi Bool)]
builtin_commands = [
("add", keepGoing addModule),
("browse", keepGoing browseCmd),
("cd", keepGoing changeDirectory),
("def", keepGoing defineMacro),
("help", keepGoing help),
......@@ -110,6 +112,7 @@ helpText = "\
\\
\ <stmt> evaluate/run <stmt>\n\
\ :add <filename> ... add module(s) to the current target set\n\
\ :browse [*]<module> display the names defined by <module>\n\
\ :cd <dir> change directory to <dir>\n\
\ :def <cmd> <expr> define a command :<cmd>\n\
\ :help, :? display this list of commands\n\
......@@ -615,6 +618,70 @@ quit _ = return True
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
-----------------------------------------------------------------------------
-- Browing a module's contents
browseCmd :: String -> GHCi ()
browseCmd m =
case words m of
['*':m] | looksLikeModuleName m -> browseModule m True
[m] | looksLikeModuleName m -> browseModule m False
_ -> throwDyn (CmdLineError "syntax: :browse <module>")
browseModule m exports_only = do
cms <- getCmState
dflags <- io getDynFlags
is_interpreted <- io (cmModuleIsInterpreted cms m)
when (not is_interpreted && not exports_only) $
throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
-- temporarily set the context to the module we're interested in,
-- just so we can get an appropriate PrintUnqualified
(as,bs) <- io (cmGetContext cms)
cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
else cmSetContext cms dflags [m] [])
cms2 <- io (cmSetContext cms1 dflags as bs)
(cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
setCmState cms3
let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
things' = filter wantToSee things
wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
wantToSee _ = True
thing_names = map getName things
thingDecl thing@(AnId id) = ifaceTyThing thing
thingDecl thing@(AClass c) =
let rn_decl = ifaceTyThing thing in
case rn_decl of
ClassDecl { tcdSigs = cons } ->
rn_decl{ tcdSigs = filter methodIsVisible cons }
other -> other
where
methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
thingDecl thing@(ATyCon t) =
let rn_decl = ifaceTyThing thing in
case rn_decl of
TyData { tcdCons = cons } ->
rn_decl{ tcdCons = filter conIsVisible cons }
other -> other
where
conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
io (putStrLn (showSDocForUser unqual (
vcat (map (ppr . thingDecl) things')))
)
where
-----------------------------------------------------------------------------
-- Setting the module context
......@@ -627,9 +694,8 @@ setContext str
'-':stuff -> (removeFromContext, words stuff)
stuff -> (newContext, words stuff)
sensible ('*':c:cs) = isUpper c && all isAlphaNumEx cs
sensible (c:cs) = isUpper c && all isAlphaNumEx cs
isAlphaNumEx c = isAlphaNum c || c == '_'
sensible ('*':m) = looksLikeModuleName m
sensible m = looksLikeModuleName m
newContext mods = do
cms <- getCmState
......@@ -1068,6 +1134,14 @@ printTimes allocs psecs
parens (text (secs_str "") <+> text "secs" <> comma <+>
int allocs <+> text "bytes")))
-----------------------------------------------------------------------------
-- utils
looksLikeModuleName [] = False
looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
isAlphaNumEx c = isAlphaNum c || c == '_'
-----------------------------------------------------------------------------
-- reverting CAFs
......
......@@ -7,7 +7,7 @@
\begin{code}
module HscMain ( HscResult(..), hscMain,
#ifdef GHCI
hscStmt, hscThing,
hscStmt, hscThing, hscModuleContents,
#endif
initPersistentCompilerState ) where
......@@ -18,7 +18,7 @@ import Interpreter
import ByteCodeGen ( byteCodeGen )
import CoreTidy ( tidyCoreExpr )
import CorePrep ( corePrepExpr )
import Rename ( renameStmt, renameRdrName )
import Rename ( renameStmt, renameRdrName, slurpIface )
import RdrName ( rdrNameOcc, setRdrNameOcc )
import RdrHsSyn ( RdrNameStmt )
import OccName ( dataName, tcClsName,
......@@ -28,10 +28,13 @@ import Id ( Id, idName, setGlobalIdDetails )
import IdInfo ( GlobalIdDetails(VanillaGlobal) )
import Name ( isLocalName )
import NameEnv ( lookupNameEnv )
import RdrName ( rdrEnvElts )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
import FastString ( mkFastString )
import Maybes ( catMaybes )
import List ( nub )
#endif
import HsSyn
......@@ -64,7 +67,7 @@ import CodeGen ( codeGen )
import CodeOutput ( codeOutput )
import Module ( ModuleName, moduleName, mkHomeModule,
moduleUserString )
moduleUserString, lookupModuleEnv )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass, printError )
import Util ( unJust )
......@@ -675,6 +678,62 @@ myParseIdentifier dflags str
#endif
\end{code}
%************************************************************************
%* *
\subsection{Find all the things defined in a module}
%* *
%************************************************************************
\begin{code}
#ifdef GHCI
hscModuleContents
:: DynFlags
-> HomeSymbolTable
-> HomeIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> Module -- module to inspect
-> Bool -- grab just the exports, or the whole toplev
-> IO (PersistentCompilerState, Maybe [TyThing])
hscModuleContents dflags hst hit pcs0 mod exports_only = do {
-- slurp the interface if necessary
(pcs1, print_unqual, maybe_rn_stuff)
<- slurpIface dflags hit hst pcs0 mod;
case maybe_rn_stuff of {
Nothing -> return (pcs0, Nothing);
Just (names, rn_decls) -> do {
-- Typecheck the declarations
maybe_pcs <-
typecheckExtraDecls dflags pcs1 hst print_unqual iNTERACTIVE rn_decls;
case maybe_pcs of {
Nothing -> return (pcs1, Nothing);
Just pcs2 ->
let { all_names
| exports_only = names
| otherwise =
let { iface = fromJust (lookupModuleEnv hit mod);
env = fromJust (mi_globals iface);
range = rdrEnvElts env;
} in
-- grab all the things from the global env that are locally def'd
nub [ n | elts <- range, GRE n LocalDef _ <- elts ];
pte = pcs_PTE pcs2;
ty_things = map (fromJust . lookupType hst pte) all_names;
} in
return (pcs2, Just ty_things)
}}}}
#endif
\end{code}
%************************************************************************
%* *
\subsection{Initial persistent state}
......
......@@ -48,11 +48,7 @@ import Name ( getName, nameModule, toRdrName, isGlobalName,
import NameEnv
import NameSet
import OccName ( pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon,
isAlgTyCon, tyConGenIds, tyConTheta, tyConTyVars,
tyConDataCons, tyConFamilySize, isPrimTyCon,
isClassTyCon, isForeignTyCon, tyConArity
)
import TyCon
import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
import FieldLabel ( fieldLabelType )
import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
......@@ -215,7 +211,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl
tcdFoType = DNType, -- The only case at present
tcdLoc = noSrcLoc }
| isPrimTyCon tycon
| isPrimTyCon tycon || isFunTyCon tycon
-- needed in GHCi for ':info Int#', for example
= TyData { tcdND = DataType,
tcdCtxt = [],
......
......@@ -6,7 +6,7 @@
\begin{code}
module Rename (
renameModule, renameStmt, renameRdrName, mkGlobalContext,
closeIfaceDecls, checkOldIface
closeIfaceDecls, checkOldIface, slurpIface
) where
#include "HsVersions.h"
......@@ -241,6 +241,31 @@ getModuleExports mod =
plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
\end{code}
%*********************************************************
%* *
\subsection{Slurp in a whole module eagerly}
%* *
%*********************************************************
\begin{code}
slurpIface
:: DynFlags -> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState -> Module
-> IO (PersistentCompilerState, PrintUnqualified,
Maybe ([Name], [RenamedHsDecl]))
slurpIface dflags hit hst pcs mod =
renameSource dflags hit hst pcs iNTERACTIVE $
let mod_name = moduleName mod
in
loadInterface contextDoc mod_name ImportByUser `thenRn` \ iface ->
let fvs = availsToNameSet [ avail | (mn,avails) <- mi_exports iface,
avail <- avails ]
in
slurpImpDecls fvs `thenRn` \ rn_imp_decls ->
returnRn (alwaysQualify, Just (nameSetToList fvs, rn_imp_decls))
\end{code}
%*********************************************************
%* *
\subsection{The main function: rename}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment