cmInfoThing, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, [(TyThing,Fixity)])
+ cmBrowseModule, -- :: CmState -> IO [TyThing]
+
CmRunResult(..),
cmRunStmt, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, CmRunResult)
import DriverUtil
import Finder
#ifdef GHCI
-import HscMain ( initPersistentCompilerState, hscThing )
+import HscMain ( initPersistentCompilerState, hscThing,
+ hscModuleContents )
#else
import HscMain ( initPersistentCompilerState )
#endif
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} =
| 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
--
import CmLink ( findModuleLinkable_maybe )
import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) )
+import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
import MkIface ( ifaceTyThing )
import DriverFlags
import DriverState
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 )
builtin_commands :: [(String, String -> GHCi Bool)]
builtin_commands = [
("add", keepGoing addModule),
+ ("browse", keepGoing browseCmd),
("cd", keepGoing changeDirectory),
("def", keepGoing defineMacro),
("help", keepGoing help),
\\
\ <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\
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
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
int allocs <+> text "bytes")))
-----------------------------------------------------------------------------
+-- utils
+
+looksLikeModuleName [] = False
+looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
+
+isAlphaNumEx c = isAlphaNum c || c == '_'
+
+-----------------------------------------------------------------------------
-- reverting CAFs
foreign import revertCAFs :: IO () -- make it "safe", just in case
\begin{code}
module HscMain ( HscResult(..), hscMain,
#ifdef GHCI
- hscStmt, hscThing,
+ hscStmt, hscThing, hscModuleContents,
#endif
initPersistentCompilerState ) where
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,
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
import CodeOutput ( codeOutput )
import Module ( ModuleName, moduleName, mkHomeModule,
- moduleUserString )
+ moduleUserString, lookupModuleEnv )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass, printError )
import Util ( unJust )
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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 )
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 = [],
\begin{code}
module Rename (
renameModule, renameStmt, renameRdrName, mkGlobalContext,
- closeIfaceDecls, checkOldIface
+ closeIfaceDecls, checkOldIface, slurpIface
) where
#include "HsVersions.h"
%*********************************************************
%* *
+\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}
%* *
%*********************************************************
projects / ghc-hetmet.git / commitdiff