From 3e392c96b4bd0daa9dba6c20b2340ac4264d2482 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 8 Apr 2005 14:51:48 +0000 Subject: [PATCH] [project @ 2005-04-08 14:51:48 by simonmar] GHC API work: - add parseName :: Session -> String -> IO [Name] - make lookupName look up in the global type environment - add data ModuleInfo - add a few ModuleInfo-related functions - add getModuleInfo :: Session -> Module -> IO ModuleInfo --- ghc/compiler/main/GHC.hs | 91 +++++++++++++++++++++++++-------- ghc/compiler/main/HscMain.lhs | 10 ++-- ghc/compiler/typecheck/TcRnDriver.lhs | 45 ++++++++++------ 3 files changed, 104 insertions(+), 42 deletions(-) diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 7f33cfc..301db13 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -42,6 +42,13 @@ module GHC ( isLoaded, topSortModuleGraph, + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoInstances, + lookupName, + -- * Interactive evaluation getBindings, getPrintUnqual, #ifdef GHCI @@ -50,7 +57,7 @@ module GHC ( getInfo, GetInfoResult, exprType, typeKind, - lookupName, + parseName, RunResult(..), runStmt, browseModule, @@ -76,6 +83,9 @@ module GHC ( -- ** Classes Class, + -- ** Instances + Instance, + -- ** Types and Kinds Type, dropForAlls, Kind, @@ -109,9 +119,9 @@ module GHC ( import qualified Linker import Linker ( HValue, extendLinkEnv ) import NameEnv ( lookupNameEnv ) -import TcRnDriver ( mkExportEnv, getModuleContents ) +import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName ) import RdrName ( plusGlobalRdrEnv ) -import HscMain ( hscGetInfo, GetInfoResult, +import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) @@ -130,7 +140,7 @@ import DataCon ( DataCon ) import Name ( Name ) import RdrName ( RdrName ) import NameEnv ( nameEnvElts ) -import SrcLoc ( Located ) +import SrcLoc ( Located(..) ) import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) @@ -1427,22 +1437,65 @@ getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) getPrintUnqual :: Session -> IO PrintUnqualified getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +#ifdef GHCI +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: Session -> String -> IO [Name] +parseName s str = withSession s $ \hsc_env -> do + maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str + case maybe_rdr_name of + Nothing -> return [] + Just (L _ rdr_name) -> do + mb_names <- tcRnLookupRdrName hsc_env rdr_name + case mb_names of + Nothing -> return [] + Just ns -> return ns + -- ToDo: should return error messages +#endif + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: Session -> Name -> IO (Maybe TyThing) +lookupName s name = withSession s $ \hsc_env -> do + case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of + Just tt -> return (Just tt) + Nothing -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + + +-- | Container for information about a 'Module'. +newtype ModuleInfo = ModuleInfo ModDetails + -- ToDo: this should really contain the ModIface too + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) +getModuleInfo s mdl = withSession s $ \hsc_env -> do + case lookupModuleEnv (hsc_HPT hsc_env) mdl of + Nothing -> return Nothing + Just hmi -> return (Just (ModuleInfo (hm_details hmi))) + -- ToDo: we should be able to call getModuleInfo on a package module, + -- even one that isn't loaded yet. + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings (ModuleInfo md) = typeEnvElts (md_types md) + +-- | An instance of a class +newtype Instance = Instance DFunId + +-- | The list of 'Instance's defined in a module +modInfoInstances :: ModuleInfo -> [Instance] +modInfoInstances (ModuleInfo md) = map Instance (md_insts md) + #if 0 -getModuleInfo :: Session -> Module -> IO ModuleInfo data ObjectCode = ByteCode | BinaryCode FilePath -data ModuleInfo = ModuleInfo { - lm_modulename :: Module, - lm_summary :: ModSummary, - lm_interface :: ModIface, - lm_tc_code :: Maybe TypecheckedCode, - lm_rn_code :: Maybe RenamedCode, - lm_obj :: Maybe ObjectCode - } - type TypecheckedCode = HsTypecheckedGroup type RenamedCode = [HsGroup Name] @@ -1560,6 +1613,7 @@ moduleIsInterpreted s modl = withSession s $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) +{-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-} getInfo :: Session -> String -> IO [GetInfoResult] getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id @@ -1589,14 +1643,6 @@ typeKind s str = withSession s $ \hsc_env -> do Just kind -> return (Just kind) ----------------------------------------------------------------------------- --- lookupName: returns the TyThing for a Name in the interactive context. --- ToDo: should look it up in the full environment - -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> do - return $! lookupNameEnv (ic_type_env (hsc_IC hsc_env)) name - ------------------------------------------------------------------------------ -- cmCompileExpr: compile an expression and deliver an HValue compileExpr :: Session -> String -> IO (Maybe HValue) @@ -1696,6 +1742,7 @@ foreign import "rts_evalStableIO" {- safe -} -- --------------------------------------------------------------------------- -- cmBrowseModule: get all the TyThings defined in a module +{-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-} browseModule :: Session -> Module -> Bool -> IO [IfaceDecl] browseModule s modl exports_only = withSession s $ \hsc_env -> do mb_decls <- getModuleContents hsc_env modl exports_only diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 83837ee..9c87db2 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -9,6 +9,7 @@ module HscMain ( HscResult(..), hscMain, newHscEnv, hscCmmFile, hscFileCheck, + hscParseIdentifier, #ifdef GHCI hscStmt, hscTcExpr, hscKcType, hscGetInfo, GetInfoResult, @@ -19,7 +20,7 @@ module HscMain ( #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LStmt, LHsExpr, LHsType ) +import HsSyn ( Stmt(..), LHsExpr ) import IfaceSyn ( IfaceDecl, IfaceInst ) import Module ( Module ) import CodeOutput ( outputForeignStubs ) @@ -33,7 +34,6 @@ import RdrName ( rdrNameOcc ) import OccName ( occNameUserString ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) -import StringBuffer ( stringToStringBuffer ) import Kind ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) @@ -44,9 +44,9 @@ import SrcLoc ( SrcLoc, noSrcLoc ) import Var ( Id ) import Module ( emptyModuleEnv ) import RdrName ( GlobalRdrEnv, RdrName ) -import HsSyn ( HsModule, LHsBinds ) +import HsSyn ( HsModule, LHsBinds, LStmt, LHsType ) import SrcLoc ( Located(..) ) -import StringBuffer ( hGetStringBuffer ) +import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) import Parser import Lexer ( P(..), ParseResult(..), mkPState ) import SrcLoc ( mkSrcLoc ) @@ -648,6 +648,7 @@ hscKcType hsc_env str Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ; return Nothing } ; Nothing -> return Nothing } } +#endif \end{code} \begin{code} @@ -686,7 +687,6 @@ hscParseThing parser dflags str dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing); return (Just thing) }} -#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 6e22192..ea800bf 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -9,6 +9,7 @@ module TcRnDriver ( mkExportEnv, getModuleContents, tcRnStmt, tcRnGetInfo, GetInfoResult, tcRnExpr, tcRnType, + tcRnLookupRdrName, #endif tcRnModule, tcTopSrcDecls, @@ -757,7 +758,6 @@ check_main ghci_mode tcg_env main_mod main_fn <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) \end{code} - %********************************************************* %* * GHCi stuff @@ -1129,22 +1129,15 @@ type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc, [(IfaceType,SrcLoc)] -- Instances ) -tcRnGetInfo :: HscEnv - -> InteractiveContext - -> RdrName - -> IO (Maybe [GetInfoResult]) +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) --- Used to implemnent :info in GHCi --- --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnGetInfo hsc_env ictxt rdr_name +tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env ictxt $ do { + setInteractiveContext hsc_env (hsc_IC hsc_env) $ + lookup_rdr_name rdr_name + +lookup_rdr_name rdr_name = do { -- If the identifier is a constructor (begins with an -- upper-case letter), then we need to consider both -- constructor and type class identifiers. @@ -1169,7 +1162,29 @@ tcRnGetInfo hsc_env ictxt rdr_name do { addMessages (head errs_s) ; failM } else -- Add deprecation warnings mapM_ addMessages warns_s ; - + + return good_names + } + + +tcRnGetInfo :: HscEnv + -> InteractiveContext + -> RdrName + -> IO (Maybe [GetInfoResult]) + +-- Used to implemnent :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env ictxt rdr_name + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do { + + good_names <- lookup_rdr_name rdr_name ; + -- And lookup up the entities, avoiding duplicates, which arise -- because constructors and record selectors are represented by -- their parent declaration -- 1.7.10.4