From 4a436b3d19d0e5496a4ff74af50492dddbd43179 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 5 Apr 2004 10:50:29 +0000 Subject: [PATCH] [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 | 18 +++++++- ghc/compiler/ghci/InteractiveUI.hs | 11 ++++- ghc/compiler/main/HscMain.lhs | 74 ++++++++++++++++++++------------- ghc/compiler/parser/Parser.y.pp | 5 ++- ghc/compiler/typecheck/TcRnDriver.lhs | 29 ++++++++++++- 5 files changed, 102 insertions(+), 35 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index c4c1913..95f31fe 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/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 ) @@ -324,6 +327,19 @@ cmTypeOfExpr cmstate expr ----------------------------------------------------------------------------- +-- 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) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 5d59c95..7977305 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# 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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 395ab86..2645572 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/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("") 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("") 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} diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index dbe8eb6..5cd9be4 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/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 } diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 2b1ba61..83c99a6 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/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 -- 1.7.10.4