From 03b874e796c49ed6c6d23e07f1a14c5dcb35c5ce Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 24 Jan 2002 16:55:37 +0000 Subject: [PATCH] [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. --- ghc/compiler/compMan/CompManager.lhs | 33 ++++++++++--- ghc/compiler/ghci/InteractiveUI.hs | 84 ++++++++++++++++++++++++++++++++-- ghc/compiler/main/HscMain.lhs | 65 ++++++++++++++++++++++++-- ghc/compiler/main/MkIface.lhs | 8 +--- ghc/compiler/rename/Rename.lhs | 27 ++++++++++- 5 files changed, 196 insertions(+), 21 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 691d499..546e23f 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -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. diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 11d41c7..5ad3e48 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# 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 = "\ \\ \ evaluate/run \n\ \ :add ... add module(s) to the current target set\n\ +\ :browse [*] display the names defined by \n\ \ :cd change directory to \n\ \ :def define a command :\n\ \ :help, :? display this list of commands\n\ @@ -616,6 +619,70 @@ 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 ") + +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 @@ -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 @@ -1069,6 +1135,14 @@ printTimes allocs psecs 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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 7774426..a6954dd 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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 ) @@ -677,6 +680,62 @@ myParseIdentifier dflags str %************************************************************************ %* * +\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} %* * %************************************************************************ diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 4eed2e6..100607f 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -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 = [], diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c99a63a..e49f9fb 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -6,7 +6,7 @@ \begin{code} module Rename ( renameModule, renameStmt, renameRdrName, mkGlobalContext, - closeIfaceDecls, checkOldIface + closeIfaceDecls, checkOldIface, slurpIface ) where #include "HsVersions.h" @@ -243,6 +243,31 @@ getModuleExports mod = %********************************************************* %* * +\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} %* * %********************************************************* -- 1.7.10.4