Commit 4a436b3d authored by simonpj's avatar simonpj

[project @ 2004-04-05 10:50:24 by simonpj]

Add :k(ind) command to ghci to find the kind of a type.
This works very, very similarly to :t(ype)
parent 86b3c951
......@@ -37,6 +37,9 @@ module CompManager (
cmTypeOfExpr, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, Maybe String)
cmKindOfType, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, Maybe String)
cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
HValue,
......@@ -81,7 +84,7 @@ import Maybes ( expectJust, orElse, mapCatMaybes )
import DATA_IOREF ( readIORef )
#ifdef GHCI
import HscMain ( hscThing, hscStmt, hscTcExpr )
import HscMain ( hscThing, hscStmt, hscTcExpr, hscKcType )
import TcRnDriver ( mkExportEnv, getModuleContents )
import IfaceSyn ( IfaceDecl )
import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
......@@ -323,6 +326,19 @@ cmTypeOfExpr cmstate expr
tidy_ty = tidyType emptyTidyEnv ty
-----------------------------------------------------------------------------
-- cmKindOfType: returns a string representing the kind of a type
cmKindOfType :: CmState -> String -> IO (Maybe String)
cmKindOfType cmstate str
= do maybe_stuff <- hscKcType (cm_hsc cmstate) (cm_ic cmstate) str
case maybe_stuff of
Nothing -> return Nothing
Just kind -> return (Just str)
where
str = showSDocForUser unqual (text str <+> dcolon <+> ppr kind)
unqual = icPrintUnqual (cm_ic cmstate)
-----------------------------------------------------------------------------
-- cmTypeOfName: returns a string representing the type of a name.
......
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.163 2004/02/01 23:43:02 dons Exp $
-- $Id: InteractiveUI.hs,v 1.164 2004/04/05 10:50:26 simonpj Exp $
--
-- GHC Interactive User Interface
--
......@@ -97,6 +97,7 @@ builtin_commands = [
("set", keepGoing setCmd),
("show", keepGoing showCmd),
("type", keepGoing typeOfExpr),
("kind", keepGoing kindOfType),
("unset", keepGoing unsetOptions),
("undef", keepGoing undefineMacro),
("quit", quit)
......@@ -668,6 +669,14 @@ typeOfExpr str
Nothing -> return ()
Just tystr -> io (putStrLn tystr)
kindOfType :: String -> GHCi ()
kindOfType str
= do cms <- getCmState
maybe_tystr <- io (cmKindOfType cms str)
case maybe_tystr of
Nothing -> return ()
Just tystr -> io (putStrLn tystr)
quit :: String -> GHCi Bool
quit _ = return True
......
......@@ -8,7 +8,7 @@
module HscMain (
HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd
#ifdef GHCI
, hscStmt, hscTcExpr, hscThing,
, hscStmt, hscTcExpr, hscKcType, hscThing,
, compileExpr
#endif
) where
......@@ -16,7 +16,7 @@ module HscMain (
#include "HsVersions.h"
#ifdef GHCI
import HsSyn ( Stmt(..), LStmt, LHsExpr )
import HsSyn ( Stmt(..), LStmt, LHsExpr, LHsType )
import IfaceSyn ( IfaceDecl )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
......@@ -24,14 +24,14 @@ import Linker ( HValue, linkExpr )
import TidyPgm ( tidyCoreExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing )
import RdrName ( RdrName, GlobalRdrEnv )
import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing, tcRnType )
import RdrName ( RdrName )
import Type ( Type )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
import SrcLoc ( noSrcLoc, Located(..) )
import Kind ( Kind )
import Var ( Id )
import Name ( Name )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import BasicTypes ( Fixity )
......@@ -528,8 +528,9 @@ hscStmt -- Compile a stmt all the way to an HValue, but don't run it
hscStmt hsc_env icontext stmt
= do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
; case maybe_stmt of {
Nothing -> return Nothing ;
Just parsed_stmt -> do {
Nothing -> return Nothing ; -- Parse error
Just Nothing -> return Nothing ; -- Empty line
Just (Just parsed_stmt) -> do { -- The real stuff
-- Rename and typecheck it
maybe_tc_result
......@@ -557,16 +558,45 @@ hscTcExpr -- Typecheck an expression (but don't run it)
hscTcExpr hsc_env icontext expr
= do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
; case maybe_stmt of {
Just (L _ (ExprStmt expr _))
Nothing -> return Nothing ; -- Parse error
Just (Just (L _ (ExprStmt expr _)))
-> tcRnExpr hsc_env icontext expr ;
Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
return Nothing } ;
} }
hscKcType -- Find the kind of a type
:: HscEnv
-> InteractiveContext -- Context for compiling
-> String -- The type
-> IO (Maybe Kind)
hscKcType hsc_env icontext str
= do { maybe_type <- hscParseType (hsc_dflags hsc_env) str
; case maybe_type of {
Just ty -> tcRnType hsc_env icontext ty ;
Just other -> do { hPutStrLn stderr ("not an type: `" ++ str ++ "'") ;
return Nothing } ;
Nothing -> return Nothing } }
\end{code}
\begin{code}
hscParseStmt :: DynFlags -> String -> IO (Maybe (LStmt RdrName))
hscParseStmt dflags str
hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
hscParseStmt = hscParseThing parseStmt
hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
hscParseType = hscParseThing parseType
hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
hscParseIdentifier = hscParseThing parseIdentifier
hscParseThing :: Outputable thing
=> Lexer.P thing
-> DynFlags -> String
-> IO (Maybe thing)
-- Nothing => Parse error (message already printed)
-- Just x => success
hscParseThing parser dflags str
= do showPass dflags "Parser"
_scc_ "Parser" do
......@@ -574,20 +604,17 @@ hscParseStmt dflags str
let loc = mkSrcLoc FSLIT("<interactive>") 1 0
case unP parseStmt (mkPState buf loc dflags) of {
case unP parser (mkPState buf loc dflags) of {
PFailed span err -> do { printError span err;
return Nothing };
-- no stmt: the line consisted of just space or comments
POk _ Nothing -> return Nothing;
POk _ (Just rdr_stmt) -> do {
POk _ thing -> do {
--ToDo: can't free the string buffer until we've finished this
-- compilation sweep and all the identifiers have gone away.
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
return (Just rdr_stmt)
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
return (Just thing)
}}
#endif
\end{code}
......@@ -607,7 +634,7 @@ hscThing -- like hscStmt, but deals with a single identifier
-> IO [(IfaceDecl, Fixity)]
hscThing hsc_env ic str
= do maybe_rdr_name <- myParseIdentifier (hsc_dflags hsc_env) str
= do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
case maybe_rdr_name of {
Nothing -> return [];
Just (L _ rdr_name) -> do
......@@ -618,17 +645,6 @@ hscThing hsc_env ic str
Nothing -> return [] ;
Just things -> return things
}}
myParseIdentifier dflags str
= do buf <- stringToStringBuffer str
let loc = mkSrcLoc FSLIT("<interactive>") 1 0
case unP parseIdentifier (mkPState buf loc dflags) of
PFailed span err -> do { printError span err;
return Nothing }
POk _ rdr_name -> return (Just rdr_name)
#endif
\end{code}
......
......@@ -8,7 +8,7 @@
-- ---------------------------------------------------------------------------
{
module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where
module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where
#define INCLUDE #include
INCLUDE "HsVersions.h"
......@@ -263,6 +263,7 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T
%name parseStmt maybe_stmt
%name parseIdentifier identifier
%name parseIface iface
%name parseType ctype
%tokentype { Located Token }
%%
......@@ -753,7 +754,7 @@ context :: { LHsContext RdrName }
: btype {% checkContext $1 }
type :: { LHsType RdrName }
: ipvar '::' gentype { LL (HsPredTy (LL $ HsIParam (unLoc $1) $3)) }
: ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
| gentype { $1 }
gentype :: { LHsType RdrName }
......
......@@ -6,7 +6,8 @@
\begin{code}
module TcRnDriver (
#ifdef GHCI
mkExportEnv, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
mkExportEnv, getModuleContents, tcRnStmt,
tcRnThing, tcRnExpr, tcRnType,
#endif
tcRnModule,
tcTopSrcDecls,
......@@ -63,7 +64,7 @@ import Outputable
import HscTypes ( ModGuts(..), HscEnv(..),
GhciMode(..), noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TypeEnv, typeEnvTyCons,
ForeignStubs(NoStubs), TypeEnv,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
......@@ -76,12 +77,14 @@ import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
import TcHsType ( kcHsType )
import TcExpr ( tcCheckRho )
import TcMType ( zonkTcType )
import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcStdSyntaxName )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
......@@ -95,6 +98,7 @@ import MkId ( unsafeCoerceId )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import SrcLoc ( interactiveSrcLoc, unLoc )
import Kind ( Kind )
import Var ( globaliseId )
import Name ( nameOccName, nameModuleName )
import NameEnv ( delListFromNameEnv )
......@@ -421,6 +425,27 @@ tcRnExpr hsc_env ictxt rdr_expr
smpl_doc = ptext SLIT("main expression")
\end{code}
tcRnExpr just finds the kind of a type
\begin{code}
tcRnType :: HscEnv
-> InteractiveContext
-> LHsType RdrName
-> IO (Maybe Kind)
tcRnType hsc_env ictxt rdr_type
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext ictxt $ do {
rn_type <- rnLHsType doc rdr_type ;
failIfErrsM ;
-- Now kind-check the type
(ty', kind) <- kcHsType rn_type ;
return kind
}
where
doc = ptext SLIT("In GHCi input")
\end{code}
\begin{code}
tcRnThing :: HscEnv
......
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