Add :k(ind) command to ghci to find the kind of a type.
This works very, very similarly to :t(ype)
cmTypeOfExpr, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, Maybe String)
+ cmKindOfType, -- :: CmState -> DynFlags -> String
+ -- -> IO (CmState, Maybe String)
+
cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
HValue,
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 )
-----------------------------------------------------------------------------
+-- 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.
cmTypeOfName :: CmState -> Name -> IO (Maybe String)
{-# 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
--
("set", keepGoing setCmd),
("show", keepGoing showCmd),
("type", keepGoing typeOfExpr),
+ ("kind", keepGoing kindOfType),
("unset", keepGoing unsetOptions),
("undef", keepGoing undefineMacro),
("quit", quit)
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
module HscMain (
HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd
#ifdef GHCI
- , hscStmt, hscTcExpr, hscThing,
+ , hscStmt, hscTcExpr, hscKcType, hscThing,
, compileExpr
#endif
) where
#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 )
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 )
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
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
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}
-> 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
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}
-- ---------------------------------------------------------------------------
{
-module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where
+module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where
#define INCLUDE #include
INCLUDE "HsVersions.h"
%name parseStmt maybe_stmt
%name parseIdentifier identifier
%name parseIface iface
+%name parseType ctype
%tokentype { Located Token }
%%
: 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 }
\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkExportEnv, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
+ mkExportEnv, getModuleContents, tcRnStmt,
+ tcRnThing, tcRnExpr, tcRnType,
#endif
tcRnModule,
tcTopSrcDecls,
import HscTypes ( ModGuts(..), HscEnv(..),
GhciMode(..), noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs), TypeEnv, typeEnvTyCons,
+ ForeignStubs(NoStubs), TypeEnv,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
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 )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import SrcLoc ( interactiveSrcLoc, unLoc )
+import Kind ( Kind )
import Var ( globaliseId )
import Name ( nameOccName, nameModuleName )
import NameEnv ( delListFromNameEnv )
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
projects / ghc-hetmet.git / commitdiff