[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)

ghc/compiler/compMan/CompManager.lhs

@@ -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.
 

ghc/compiler/ghci/InteractiveUI.hs

 {-# 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
 

ghc/compiler/main/HscMain.lhs

@@ -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}
 

ghc/compiler/parser/Parser.y.pp

@@ -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 }

ghc/compiler/typecheck/TcRnDriver.lhs

@@ -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