Commit dd6f34b6 authored by simonmar's avatar simonmar

[project @ 2001-08-15 14:40:24 by simonmar]

Implement the :info command for GHCi.
parent a296464e
......@@ -147,7 +147,7 @@ cmInit mode = do
cmSetContext :: CmState -> String -> IO CmState
cmSetContext cmstate str
= do let mn = mkModuleName str
modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ]
modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ]
m <- case lookup mn modules_loaded of
Just m -> return m
......@@ -172,15 +172,25 @@ moduleNameToModule mn
++ moduleNameUserString mn ++ "'"))
Just (m,_) -> return m
-----------------------------------------------------------------------------
-- cmInfoThing: convert a String to a TyThing
-- A string may refer to more than one TyThing (eg. a constructor,
-- and type constructor), so we return a list of all the possible TyThings.
cmInfoThing :: CmState -> DynFlags -> String
-> IO (CmState, PrintUnqualified, [TyThing])
cmInfoThing cmstate dflags id
= do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id
return (cmstate{ pcs=new_pcs }, unqual, things)
where
CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
unqual = getUnqual pcs hit icontext
-----------------------------------------------------------------------------
-- cmRunStmt: Run a statement/expr.
#ifdef GHCI
cmInfoThing :: CmState -> DynFlags -> String -> IO (Maybe TyThing)
cmInfoThing CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } dflags id
= do (pcs, thing) <- hscThing dflags hst hit pcs icontext id
return thing
cmRunStmt :: CmState -> DynFlags -> String
-> IO (CmState, -- new state
[Name]) -- names bound by this evaluation
......@@ -248,19 +258,23 @@ cmTypeOfExpr cmstate dflags expr
case maybe_stuff of
Nothing -> return (new_cmstate, Nothing)
Just (_, ty, _) ->
let pit = pcs_PIT pcs
modname = moduleName (ic_module ic)
tidy_ty = tidyType emptyTidyEnv ty
str = case lookupIfaceByModName hit pit modname of
Nothing -> showSDoc (ppr tidy_ty)
Just iface -> showSDocForUser unqual (ppr tidy_ty)
where unqual = unQualInScope (mi_globals iface)
in return (new_cmstate, Just str)
Just (_, ty, _) -> return (new_cmstate, Just str)
where
str = showSDocForUser unqual (ppr tidy_ty)
unqual = getUnqual pcs hit ic
tidy_ty = tidyType emptyTidyEnv ty
where
CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate
#endif
getUnqual pcs hit ic
= case lookupIfaceByModName hit pit modname of
Nothing -> alwaysQualify
Just iface -> unQualInScope (mi_globals iface)
where
pit = pcs_PIT pcs
modname = moduleName (ic_module ic)
-----------------------------------------------------------------------------
-- cmTypeOfName: returns a string representing the type of a name.
......@@ -269,15 +283,11 @@ cmTypeOfName :: CmState -> Name -> IO (Maybe String)
cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
= case lookupNameEnv (ic_type_env ic) name of
Nothing -> return Nothing
Just (AnId id) ->
let pit = pcs_PIT pcs
modname = moduleName (ic_module ic)
ty = tidyType emptyTidyEnv (idType id)
str = case lookupIfaceByModName hit pit modname of
Nothing -> showSDoc (ppr ty)
Just iface -> showSDocForUser unqual (ppr ty)
where unqual = unQualInScope (mi_globals iface)
in return (Just str)
Just (AnId id) -> return (Just str)
where
unqual = getUnqual pcs hit ic
ty = tidyType emptyTidyEnv (idType id)
str = showSDocForUser unqual (ppr ty)
_ -> panic "cmTypeOfName"
#endif
......
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.85 2001/08/13 15:49:37 simonmar Exp $
-- $Id: InteractiveUI.hs,v 1.86 2001/08/15 14:40:24 simonmar Exp $
--
-- GHC Interactive User Interface
--
......@@ -16,7 +16,7 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
import Packages
import CompManager
import HscTypes ( GhciMode(..) )
import HscTypes ( GhciMode(..), TyThing(..) )
import MkIface ( ifaceTyCls )
import ByteCodeLink
import DriverFlags
......@@ -25,7 +25,11 @@ import DriverUtil
import Linker
import Finder ( flushPackageCache )
import Util
import Name ( Name )
import Id ( isDataConWrapId, idName )
import Class ( className )
import TyCon ( tyConName )
import SrcLoc ( isGoodSrcLoc )
import Name ( Name, isHomePackageName, nameSrcLoc )
import Outputable
import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
import Panic ( GhcException(..) )
......@@ -377,14 +381,42 @@ info :: String -> GHCi ()
info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
info s = do
let names = words s
st <- getGHCiState
let cmst = cmstate st
state <- getGHCiState
dflags <- io getDynFlags
things <- io (mapM (cmInfoThing cmst dflags) names)
let real_things = [ x | Just x <- things ]
let descs = map (`ifaceTyCls` []) real_things
let strings = map (showSDoc . ppr) descs
io (mapM_ putStr strings)
let
infoThings cms [] = return cms
infoThings cms (name:names) = do
(cms, unqual, ty_things) <- io (cmInfoThing cms dflags name)
io (putStrLn (showSDocForUser unqual (
vcat (intersperse (text "") (map showThing ty_things))))
)
infoThings cms names
showThing ty_thing = vcat [ text "-- " <> showTyThing ty_thing,
ppr (ifaceTyCls ty_thing) ]
showTyThing (AClass cl)
= hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
showTyThing (ATyCon ty)
= hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
showTyThing (AnId id)
| isDataConWrapId id
= hcat [ppr id, text " is a data constructor", showSrcLoc (idName id)]
| otherwise
= hcat [ppr id, text " is a variable", showSrcLoc (idName id)]
-- also print out the source location for home things
showSrcLoc name
| isHomePackageName name && isGoodSrcLoc loc
= hsep [ text ", defined at", ppr loc ]
| otherwise
= empty
where loc = nameSrcLoc name
cms <- infoThings (cmstate state) names
setGHCiState state{ cmstate = cms }
return ()
addModule :: String -> GHCi ()
addModule str = do
......
......@@ -17,11 +17,10 @@ module HscMain ( HscResult(..), hscMain,
import ByteCodeGen ( byteCodeGen )
import CoreTidy ( tidyCoreExpr )
import CorePrep ( corePrepExpr )
import SrcLoc ( noSrcLoc )
import Rename ( renameStmt )
import RdrName ( mkUnqual )
import Rename ( renameStmt, renameRdrName )
import RdrName ( mkUnqual, mkQual )
import RdrHsSyn ( RdrNameStmt )
import OccName ( dataName )
import OccName ( varName, dataName, tcClsName )
import Type ( Type )
import Id ( Id, idName, setGlobalIdDetails )
import IdInfo ( GlobalIdDetails(VanillaGlobal) )
......@@ -29,6 +28,8 @@ import HscTypes ( InteractiveContext(..) )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
import FastString ( mkFastString )
import Char ( isLower )
import DriverUtil ( split_longest_prefix )
#endif
import HsSyn
......@@ -79,7 +80,7 @@ import Module ( Module )
import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO )
import Monad ( when )
import Maybe ( isJust, fromJust )
import Maybe ( isJust, fromJust, catMaybes )
import IO
import MkExternalCore ( emitExternalCore )
......@@ -562,31 +563,6 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr
}}}}}
hscThing -- like hscStmt, but deals with a single identifier
:: DynFlags
-> HomeSymbolTable
-> HomeIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> InteractiveContext -- Context for compiling
-> String -- The identifier
-> IO ( PersistentCompilerState,
Maybe TyThing )
hscThing dflags hst hit pcs0 icontext id
= let
InteractiveContext {
ic_rn_env = rn_env,
ic_type_env = type_env,
ic_module = scope_mod } = icontext
fname = mkFastString id
rn = mkUnqual dataName fname -- need to guess correct namespace
stmt = ResultStmt (HsVar rn) noSrcLoc
in
do { (pcs, err, maybe_stmt) <- renameStmt dflags hit hst pcs0 scope_mod scope_mod rn_env stmt
; case maybe_stmt of
Nothing -> return (pcs, Nothing)
Just (n:ns, _) -> return (pcs, lookupType hst type_env n)
}
hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
hscParseStmt dflags str
= do -------------------------- Parser ----------------
......@@ -620,6 +596,64 @@ hscParseStmt dflags str
#endif
\end{code}
%************************************************************************
%* *
\subsection{Getting information about an identifer}
%* *
%************************************************************************
\begin{code}
#ifdef GHCI
hscThing -- like hscStmt, but deals with a single identifier
:: DynFlags
-> HomeSymbolTable
-> HomeIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> InteractiveContext -- Context for compiling
-> String -- The identifier
-> IO ( PersistentCompilerState,
[TyThing] )
hscThing dflags hst hit pcs0 icontext str
= do let
InteractiveContext {
ic_rn_env = rn_env,
ic_type_env = type_env,
ic_module = scope_mod } = icontext
rdr_names
| '.' `elem` str
= [ mkQual ns (fmod,fvar) | ns <- namespaces var ]
| otherwise
= [ mkUnqual ns fstr | ns <- namespaces str ]
where (mod,var) = split_longest_prefix str '.'
fmod = mkFastString mod
fvar = mkFastString var
fstr = mkFastString str
namespaces s | isLower (head s) = [ varName ]
| otherwise = [ tcClsName, dataName ]
(pcs, unqual, maybe_rn_result) <-
renameRdrName dflags hit hst pcs0 scope_mod scope_mod
rn_env rdr_names
case maybe_rn_result of {
Nothing -> return (pcs, []);
Just (names, decls) -> do {
maybe_pcs <- typecheckExtraDecls dflags pcs hst unqual
iNTERACTIVE decls;
case maybe_pcs of {
Nothing -> return (pcs, []);
Just pcs ->
let maybe_ty_things = map (lookupType hst (pcs_PTE pcs)) names
in
return (pcs, catMaybes maybe_ty_things) }
}}
#endif
\end{code}
%************************************************************************
%* *
\subsection{Initial persistent state}
......
......@@ -115,7 +115,7 @@ mkFinalIface ghci_mode dflags location
hi_file_path = ml_hi_file location
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
inst_dcls = map ifaceInstance (md_insts new_details)
ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types new_details)
ty_cls_dcls = foldNameEnv ifaceTyCls_acc [] (md_types new_details)
rule_dcls = map ifaceRule (md_rules new_details)
orphan_mod = isOrphanModule (mi_module new_iface) new_details
......@@ -137,10 +137,22 @@ isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules})
no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names)
\end{code}
Implicit Ids and class tycons aren't included in interface files, so
we miss them out of the accumulating parameter here.
\begin{code}
ifaceTyCls_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
ifaceTyCls_acc (AnId id) so_far | isImplicitId id = so_far
ifaceTyCls_acc (ATyCon id) so_far | isClassTyCon id = so_far
ifaceTyCls_acc other so_far = ifaceTyCls other : so_far
\end{code}
Convert *any* TyThing into a RenamedTyClDecl. Used both for
generating interface files and for the ':info' command in GHCi.
\begin{code}
ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
ifaceTyCls (AClass clas) so_far
= cls_decl : so_far
ifaceTyCls :: TyThing -> RenamedTyClDecl
ifaceTyCls (AClass clas) = cls_decl
where
cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta,
tcdName = getName clas,
......@@ -167,9 +179,7 @@ ifaceTyCls (AClass clas) so_far
GenDefMeth -> GenDefMeth
DefMeth id -> DefMeth (getName id)
ifaceTyCls (ATyCon tycon) so_far
| isClassTyCon tycon = so_far
| otherwise = ty_decl : so_far
ifaceTyCls (ATyCon tycon) = ty_decl
where
ty_decl | isSynTyCon tycon
= TySynonym { tcdName = getName tycon,
......@@ -221,9 +231,7 @@ ifaceTyCls (ATyCon tycon) so_far
mk_field strict_mark field_label
= ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
ifaceTyCls (AnId id) so_far
| isImplicitId id = so_far
| otherwise = iface_sig : so_far
ifaceTyCls (AnId id) = iface_sig
where
iface_sig = IfaceSig { tcdName = getName id,
tcdType = toHsType id_type,
......
......@@ -4,7 +4,10 @@
\section[Rename]{Renaming and dependency analysis passes}
\begin{code}
module Rename ( renameModule, renameStmt, closeIfaceDecls, checkOldIface ) where
module Rename (
renameModule, renameStmt, renameRdrName,
closeIfaceDecls, checkOldIface
) where
#include "HsVersions.h"
......@@ -34,8 +37,9 @@ import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules,
lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs,
newGlobalName, unQualInScope,, ubiquitousNames
lookupSrcName, getImplicitStmtFVs,
getImplicitModuleFVs, newGlobalName, unQualInScope,
ubiquitousNames, lookupOccRn
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
......@@ -73,7 +77,7 @@ import List ( partition, nub )
%*********************************************************
%* *
\subsection{The two main wrappers}
\subsection{The main wrappers}
%* *
%*********************************************************
......@@ -91,7 +95,6 @@ renameModule dflags hit hst pcs this_module rdr_module
rename this_module rdr_module
\end{code}
\begin{code}
renameStmt :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
......@@ -108,54 +111,103 @@ renameStmt :: DynFlags
renameStmt dflags hit hst pcs scope_module this_module local_env stmt
= renameSource dflags hit hst pcs this_module $
-- Load the interface for the context module, so
-- that we can get its top-level lexical environment
-- Bale out if we fail to do this
loadInterface doc (moduleName scope_module) ImportByUser `thenRn` \ iface ->
let rdr_env = mi_globals iface
print_unqual = unQualInScope rdr_env
in
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
returnRn (print_unqual, Nothing)
else
-- load the context module
loadContextModule scope_module $ \ (rdr_env, print_unqual) ->
-- Rename it
-- Rename the stmt
initRnMS rdr_env local_env emptyLocalFixityEnv CmdLineMode (
rnStmt stmt $ \ stmt' ->
returnRn (([], stmt'), emptyFVs)
) `thenRn` \ ((binders, stmt), fvs) ->
) `thenRn` \ ((binders, stmt), fvs) ->
-- Bale out if we fail
checkErrsRn `thenRn` \ no_errs_so_far ->
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
doDump [] stmt [] `thenRn_` returnRn (print_unqual, Nothing)
doDump dflags [] stmt [] `thenRn_` returnRn (print_unqual, Nothing)
else
-- Add implicit free vars, and close decls
getImplicitStmtFVs `thenRn` \ implicit_fvs ->
let
filtered_fvs = fvs `delListFromNameSet` rdrEnvElts local_env
source_fvs = implicit_fvs `plusFV` filtered_fvs
in
slurpImpDecls source_fvs `thenRn` \ decls ->
slurpImplicitDecls fvs local_env `thenRn` \ decls ->
doDump binders stmt decls `thenRn_`
doDump dflags binders stmt decls `thenRn_`
returnRn (print_unqual, Just (binders, (stmt, decls)))
where
doc = text "context for compiling expression"
doDump :: [Name] -> RenamedStmt -> [RenamedHsDecl] -> RnMG (Either IOError ())
doDump bndrs stmt decls
= getDOptsRn `thenRn` \ dflags ->
ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:"
doDump :: DynFlags -> [Name] -> RenamedStmt -> [RenamedHsDecl]
-> RnMG (Either IOError ())
doDump dflags bndrs stmt decls
= ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:"
(vcat [text "Binders:" <+> ppr bndrs,
ppr stmt, text "",
vcat (map ppr decls)]))
\end{code}
renameRdrName
:: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -- current context (scope to compile in)
-> Module -- current module
-> LocalRdrEnv -- current context (temp bindings)
-> [RdrName] -- name to rename
-> IO ( PersistentCompilerState,
PrintUnqualified,
Maybe ([Name], [RenamedHsDecl])
)
renameRdrName dflags hit hst pcs scope_module this_module local_env rdr_names =
renameSource dflags hit hst pcs this_module $
loadContextModule scope_module $ \ (rdr_env, print_unqual) ->
-- rename the rdr_name
initRnMS rdr_env local_env emptyLocalFixityEnv CmdLineMode
(mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names ->
let
ok_names = [ a | Right a <- maybe_names ]
in
if null ok_names
then let errs = head [ e | Left e <- maybe_names ]
in setErrsRn errs `thenRn_`
doDump dflags ok_names [] `thenRn_`
returnRn (print_unqual, Nothing)
else
slurpImplicitDecls (mkNameSet ok_names) local_env `thenRn` \ decls ->
doDump dflags ok_names decls `thenRn_`
returnRn (print_unqual, Just (ok_names, decls))
where
doDump :: DynFlags -> [Name] -> [RenamedHsDecl] -> RnMG (Either IOError ())
doDump dflags names decls
= ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:"
(vcat [ppr names, text "",
vcat (map ppr decls)]))
-- Load the interface for the context module, so
-- that we can get its top-level lexical environment
-- Bale out if we fail to do this
loadContextModule scope_module thing_inside
= let doc = text "context for compiling expression"
in
loadInterface doc (moduleName scope_module) ImportByUser `thenRn` \ iface ->
let rdr_env = mi_globals iface
print_unqual = unQualInScope rdr_env
in
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
returnRn (print_unqual, Nothing)
else
thing_inside (rdr_env, print_unqual)
-- Add implicit free vars, and close decls
slurpImplicitDecls fvs local_env
= getImplicitStmtFVs `thenRn` \ implicit_fvs ->
let
filtered_fvs = fvs `delListFromNameSet` rdrEnvElts local_env
source_fvs = implicit_fvs `plusFV` filtered_fvs
in
slurpImpDecls source_fvs
\end{code}
%*********************************************************
%* *
\subsection{The main function: rename}
......
......@@ -551,6 +551,21 @@ warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
where
warn = addShortWarnLocLine loc msg
tryRn :: RnM d a -> RnM d (Either Messages a)
tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down
= do current_msgs <- readIORef errs_var
writeIORef errs_var (emptyBag,emptyBag)
a <- try_this down l_down
(warns, errs) <- readIORef errs_var
writeIORef errs_var current_msgs
if (isEmptyBag errs)
then return (Right a)
else return (Left (warns,errs))
setErrsRn :: Messages -> RnM d ()
setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down
= do writeIORef errs_var msgs; return ()
addErrRn :: Message -> RnM d ()
addErrRn err = failWithRn () err
......
......@@ -6,6 +6,7 @@
\begin{code}
module TcModule (
typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
typecheckExtraDecls,
TcResults(..)
) where
......@@ -287,6 +288,33 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
smpl_doc = ptext SLIT("main expression")
\end{code}
%************************************************************************
%* *
\subsection{Typechecking extra declarations}
%* *
%************************************************************************
\begin{code}
typecheckExtraDecls
:: DynFlags
-> PersistentCompilerState
-> HomeSymbolTable
-> PrintUnqualified -- For error printing
-> Module -- Is this really needed
-> [RenamedHsDecl] -- extra decls sucked in from interface files
-> IO (Maybe PersistentCompilerState)
typecheckExtraDecls dflags pcs hst unqual this_mod decls
= typecheck dflags pcs hst unqual $
fixTc (\ ~(unf_env, _, _, _, _) ->
tcImports unf_env pcs hst get_fixity this_mod decls
) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
returnTc new_pcs
where
get_fixity n = pprPanic "typecheckExpr" (ppr n)
\end{code}
%************************************************************************
%* *
\subsection{Typechecking a module}
......
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