From: rrt Date: Wed, 18 Jul 2001 16:06:11 +0000 (+0000) Subject: [project @ 2001-07-18 16:06:10 by rrt] X-Git-Tag: Approximately_9120_patches~1515 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0143969c73e0071df19a103979b6861ca1df0bb9;p=ghc-hetmet.git [project @ 2001-07-18 16:06:10 by rrt] Add support for Hugs's :info command. Doesn't work yet, but shouldn't interfere with anything else. Some of the files touched are just to correct out-of-date comments. Highlights are: hscThing: like hscStmt, but just gets info about a single identifier cmInfoThing: exposes hscThing's functionality to the outside world --- diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 30f0b58..a229e2c 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -16,10 +16,12 @@ module CompManager ( cmGetContext, -- :: CmState -> IO String #ifdef GHCI - cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, [Name]) + cmInfoThing, -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing) - cmTypeOfExpr, -- :: CmState -> DynFlags -> String - -- -> IO (CmState, Maybe String) + cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, [Name]) + + cmTypeOfExpr, -- :: CmState -> DynFlags -> String + -- -> IO (CmState, Maybe String) cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String) @@ -39,7 +41,7 @@ import DriverFlags ( getDynFlags ) import DriverPhases import DriverUtil import Finder -import HscMain ( initPersistentCompilerState ) +import HscMain ( initPersistentCompilerState, hscThing ) import HscTypes import RnEnv ( unQualInScope ) import Id ( idType, idName ) @@ -170,6 +172,11 @@ moduleNameToModule mn -- 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 diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index d5d718f..0693b36 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -511,7 +511,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty DoExpr -> True ListComp -> False - -- For ExprStmt, see the comments near HsExpr.HsStmt about + -- For ExprStmt, see the comments near HsExpr.Stmt about -- exactly what ExprStmts mean! -- -- In dsDo we can only see DoStmt and ListComp (no gaurds) diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 0e562e5..5f101fc 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -74,7 +74,7 @@ matchGuard :: [TypecheckedStmt] -- Guard -> DsMatchContext -- Context -> DsM MatchResult --- See comments with HsExpr.HsStmt re what an ExprStmt means +-- See comments with HsExpr.Stmt re what an ExprStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) matchGuard [ResultStmt expr locn] ctx diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 685cf84..d7ea01f 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.81 2001/07/17 14:53:48 rrt Exp $ +-- $Id: InteractiveUI.hs,v 1.82 2001/07/18 16:06:10 rrt Exp $ -- -- GHC Interactive User Interface -- @@ -16,6 +16,7 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where import Packages import CompManager import HscTypes ( GhciMode(..) ) +import MkIface ( ifaceTyCls ) import ByteCodeLink import DriverFlags import DriverState @@ -71,6 +72,7 @@ builtin_commands = [ ("def", keepGoing defineMacro), ("help", keepGoing help), ("?", keepGoing help), + ("info", keepGoing info), ("load", keepGoing loadModule), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), @@ -88,12 +90,14 @@ shortHelpText = "use :? for help.\n" helpText = "\ \ Commands available from the prompt:\n\ -\\ +\\ \ evaluate/run \n\ \ :add ... add module(s) to the current target set\n\ \ :cd change directory to \n\ \ :def define a command :\n\ \ :help, :? display this list of commands\n\ +\ :info [ ...] display information about the given names, or\n\ +\ about currently loaded files if no names given\n\ \ :load ... load module(s) and their dependents\n\ \ :module set the context for expression evaluation to \n\ \ :reload reload the current module set\n\ @@ -200,11 +204,10 @@ runGHCi = do -- and aren't world writable. Otherwise, we could be accidentally -- running code planted by a malicious third party. --- Furthermore, We only read ./.ghci if both . and ./.ghci are --- owned by the current user and aren't writable by anyone else. I --- think this is sufficient: we don't need to check .. and --- ../.. etc. because "." always refers to the same directory while a --- process is running. +-- Furthermore, We only read ./.ghci if . is owned by the current user +-- and isn't writable by anyone else. I think this is sufficient: we +-- don't need to check .. and ../.. etc. because "." always refers to +-- the same directory while a process is running. checkPerms :: String -> IO Bool checkPerms name = @@ -364,6 +367,19 @@ noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments")) help :: String -> GHCi () help _ = io (putStr helpText) +info :: String -> GHCi () +info "" = do io (putStr "dunno, mate") +info s = do + let names = words s + st <- getGHCiState + let cmst = cmstate st + 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) + addModule :: String -> GHCi () addModule str = do let files = words str @@ -643,7 +659,8 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) -io m = GHCi $ \s -> m >>= \a -> return a +io :: IO a -> GHCi a +io m = GHCi { unGHCi = \s -> m >>= return } ----------------------------------------------------------------------------- -- recursive exception handlers diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index a21f5f4..129166b 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, + hscStmt, hscThing, #endif initPersistentCompilerState ) where @@ -17,14 +17,18 @@ module HscMain ( HscResult(..), hscMain, import ByteCodeGen ( byteCodeGen ) import CoreTidy ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) +import SrcLoc ( noSrcLoc ) import Rename ( renameStmt ) +import RdrName ( mkUnqual ) import RdrHsSyn ( RdrNameStmt ) +import OccName ( dataName ) import Type ( Type ) import Id ( Id, idName, setGlobalIdDetails ) import IdInfo ( GlobalIdDetails(VanillaGlobal) ) import HscTypes ( InteractiveContext(..) ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) +import FastString ( mkFastString ) #endif import HsSyn @@ -551,6 +555,31 @@ 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 ---------------- diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 508ec26..ab5bf69 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -7,7 +7,8 @@ \begin{code} module MkIface ( mkFinalIface, - pprModDetails, pprIface, pprUsage + pprModDetails, pprIface, pprUsage, + ifaceTyCls, ) where #include "HsVersions.h" diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 5b3def9..6b10b9e 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -20,7 +20,7 @@ module ParseUtil ( , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) , checkPattern -- HsExp -> P HsPat , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] - , checkDo -- [HsStmt] -> P [HsStmt] + , checkDo -- [Stmt] -> P [Stmt] , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl ) where