Implement the :info command for GHCi.
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
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
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.
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
--
import Packages
import CompManager
-import HscTypes ( GhciMode(..) )
+import HscTypes ( GhciMode(..), TyThing(..) )
import MkIface ( ifaceTyCls )
import ByteCodeLink
import DriverFlags
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(..) )
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
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) )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
import FastString ( mkFastString )
+import Char ( isLower )
+import DriverUtil ( split_longest_prefix )
#endif
import HsSyn
import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO )
import Monad ( when )
-import Maybe ( isJust, fromJust )
+import Maybe ( isJust, fromJust, catMaybes )
import IO
import MkExternalCore ( emitExternalCore )
}}}}}
-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 ----------------
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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
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,
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,
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,
\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"
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,
%*********************************************************
%* *
-\subsection{The two main wrappers}
+\subsection{The main wrappers}
%* *
%*********************************************************
rename this_module rdr_module
\end{code}
-
\begin{code}
renameStmt :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
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}
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
\begin{code}
module TcModule (
typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
+ typecheckExtraDecls,
TcResults(..)
) where
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
projects / ghc-hetmet.git / commitdiff