From 920d0d7e8f4adf97a2adbc08317522e34de10c65 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 2 Mar 2001 17:35:20 +0000 Subject: [PATCH] [project @ 2001-03-02 17:35:20 by simonmar] Fix :type again, by resurrecting typecheckExpr. Now the expression doesn't get the monomorphism restriction applied to it. --- ghc/compiler/compMan/CompManager.lhs | 39 ++++++++---- ghc/compiler/main/HscMain.lhs | 36 ++++++++--- ghc/compiler/typecheck/TcModule.lhs | 112 ++++++++++++++++++++++++++++------ 3 files changed, 147 insertions(+), 40 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 0e10626..bae0a21 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -186,11 +186,11 @@ cmRunStmt cmstate dflags expr ic_module = this_mod } = icontext (new_pcs, maybe_stuff) - <- hscStmt dflags hst hit pcs icontext expr + <- hscStmt dflags hst hit pcs icontext expr False{-stmt-} case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, []) - Just (ids, bcos) -> do + Just (ids, _, bcos) -> do -- update the interactive context let @@ -227,12 +227,24 @@ cmRunStmt cmstate dflags expr #ifdef GHCI cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String) cmTypeOfExpr cmstate dflags expr - = do (new_cmstate, names) - <- cmRunStmt cmstate dflags ("let __cmTypeOfExpr = " ++ expr) - case names of - [name] -> do maybe_tystr <- cmTypeOfName new_cmstate name - return (new_cmstate, maybe_tystr) - _other -> return (new_cmstate, Nothing) + = do (new_pcs, maybe_stuff) + <- hscStmt dflags hst hit pcs ic expr True{-just an expr-} + + let new_cmstate = cmstate{pcs = new_pcs} + + case maybe_stuff of + Nothing -> return (new_cmstate, Nothing) + Just (_, ty, _) -> + let pit = pcs_PIT pcs + modname = moduleName (ic_module ic) + tidy_ty = tidyType emptyTidyEnv ty + str = case lookupIfaceByModName hit pit modname of + Nothing -> showSDoc (ppr tidy_ty) + Just iface -> showSDocForUser unqual (ppr tidy_ty) + where unqual = unQualInScope (mi_globals iface) + in return (new_cmstate, Just str) + where + CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate #endif ----------------------------------------------------------------------------- @@ -270,11 +282,11 @@ cmCompileExpr cmstate dflags expr (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs icontext - ("let __cmCompileExpr = "++expr) + ("let __cmCompileExpr = "++expr) False{-stmt-} case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) - Just (ids, bcos) -> do + Just (ids, _, bcos) -> do -- link it hval <- linkExpr pls bcos @@ -801,8 +813,13 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here source_unchanged = isJust maybe_old_linkable + -- in interactive mode, all home modules below us *must* have an + -- interface in the HIT. We never demand-load home interfaces in + -- interactive mode. (hst1_strictDC, hit1_strictDC) - = retainInTopLevelEnvs + = ASSERT(ghci_mode == Batch || + all (`elemUFM` hit1) reachable_from_here) + retainInTopLevelEnvs (filter (/= (name_of_summary summary1)) reachable_from_here) (hst1,hit1) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 29de2ac..4bbf855 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -34,6 +34,7 @@ import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE ) import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface, pprIface ) +import Type ( Type ) import TcModule import InstEnv ( emptyInstEnv ) import Desugar @@ -417,9 +418,11 @@ hscStmt -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The statement + -> Bool -- just treat it as an expression -> IO ( PersistentCompilerState, Maybe ( [Id], - UnlinkedBCOExpr) ) + Type, + UnlinkedBCOExpr) ) \end{code} When the UnlinkedBCOExpr is linked you get an HValue of type @@ -449,7 +452,7 @@ A naked expression returns a singleton Name [it]. result not showable) ==> error \begin{code} -hscStmt dflags hst hit pcs0 icontext stmt +hscStmt dflags hst hit pcs0 icontext stmt just_expr = let InteractiveContext { ic_rn_env = rn_env, @@ -461,6 +464,15 @@ hscStmt dflags hst hit pcs0 icontext stmt Nothing -> return (pcs0, Nothing) Just parsed_stmt -> do { + let { notExprStmt (ExprStmt _ _) = False; + notExprStmt _ = True + }; + + if (just_expr && notExprStmt parsed_stmt) + then do hPutStrLn stderr ("not an expression: `" ++ stmt ++ "'") + return (pcs0, Nothing) + else do { + -- Rename it (pcs1, print_unqual, maybe_renamed_stmt) <- renameStmt dflags hit hst pcs0 scope_mod @@ -471,12 +483,17 @@ hscStmt dflags hst hit pcs0 icontext stmt Just (bound_names, rn_stmt) -> do { -- Typecheck it - maybe_tc_return - <- typecheckStmt dflags pcs1 hst type_env - print_unqual iNTERACTIVE bound_names rn_stmt - ; case maybe_tc_return of { - Nothing -> return (pcs0, Nothing) ; - Just (pcs2, tc_expr, bound_ids) -> do { + maybe_tc_return <- + if just_expr + then case rn_stmt of { (syn, ExprStmt e _, decls) -> + typecheckExpr dflags pcs1 hst type_env + print_unqual iNTERACTIVE (syn,e,decls) } + else typecheckStmt dflags pcs1 hst type_env + print_unqual iNTERACTIVE bound_names rn_stmt + + ; case maybe_tc_return of + Nothing -> return (pcs0, Nothing) + Just (pcs2, tc_expr, bound_ids, ty) -> do { -- Desugar it ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr @@ -505,7 +522,8 @@ hscStmt dflags hst hit pcs0 icontext stmt = modifyIdInfo (`setFlavourInfo` makeConstantFlavour (idFlavour id)) id - ; return (pcs2, Just (constant_bound_ids, bcos)) + ; return (pcs2, Just (constant_bound_ids, ty, bcos)) + }}}}} hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index ed05fb9..9e063a0 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -5,7 +5,8 @@ \begin{code} module TcModule ( - typecheckModule, typecheckIface, typecheckStmt, TcResults(..) + typecheckModule, typecheckIface, typecheckStmt, typecheckExpr, + TcResults(..) ) where #include "HsVersions.h" @@ -21,7 +22,8 @@ import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName, itName ) import MkId ( unsafeCoerceId ) -import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt ) +import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt, + RenamedHsExpr ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, TypecheckedForeignDecl, TypecheckedRuleDecl, zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet, @@ -29,6 +31,7 @@ import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, ) +import TcExpr ( tcMonoExpr ) import TcMonad import TcType ( newTyVarTy, zonkTcType, tcInstType ) import TcMatches ( tcStmtsAndThen ) @@ -46,13 +49,12 @@ import TcRules ( tcIfaceRules, tcSourceRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop ) +import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) import CoreUnfold ( unfoldingTemplate, hasUnfolding ) import TysWiredIn ( mkListTy, unitTy ) -import Type ( funResultTy, splitForAllTys, - liftedTypeKind, mkTyConApp, tidyType ) +import Type import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass ) import Id ( Id, idType, idName, isLocalId, idUnfolding ) import Module ( Module, moduleName ) @@ -81,19 +83,23 @@ import VarSet %************************************************************************ \begin{code} -typecheckStmt :: DynFlags - -> PersistentCompilerState - -> HomeSymbolTable - -> TypeEnv -- The interactive context's type envt - -> PrintUnqualified -- For error printing - -> Module -- Is this really needed - -> [Name] -- Names bound by the Stmt (empty for expressions) - -> (SyntaxMap, - RenamedStmt, -- The stmt itself - [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files - -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, [Id])) - -- The returned [Name] is the same as the input except for - -- ExprStmt, in which case the returned [Name] is [itName] +typecheckStmt + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> TypeEnv -- The interactive context's type envt + -> PrintUnqualified -- For error printing + -> Module -- Is this really needed + -> [Name] -- Names bound by the Stmt (empty for expressions) + -> (SyntaxMap, + RenamedStmt, -- The stmt itself + [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files + -> IO (Maybe (PersistentCompilerState, + TypecheckedHsExpr, + [Id], + Type)) + -- The returned [Id] is the same as the input except for + -- ExprStmt, in which case the returned [Name] is [itName] typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls) = typecheck dflags syn_map pcs hst unqual $ @@ -120,11 +126,11 @@ typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, i ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_` ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_` - returnTc (new_pcs, zonked_expr, zonked_ids) + returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type") where get_fixity :: Name -> Maybe Fixity - get_fixity n = pprPanic "typecheckExpr" (ppr n) + get_fixity n = pprPanic "typecheckStmt" (ppr n) \end{code} Here is the grand plan, implemented in tcUserStmt @@ -211,6 +217,72 @@ tc_stmts names stmts combine stmt (ids, stmts) = (ids, stmt:stmts) \end{code} +%************************************************************************ +%* * +\subsection{Typechecking an expression} +%* * +%************************************************************************ + +\begin{code} +typecheckExpr :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> TypeEnv -- The interactive context's type envt + -> PrintUnqualified -- For error printing + -> Module + -> (SyntaxMap, + RenamedHsExpr, -- The expression itself + [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files + -> IO (Maybe (PersistentCompilerState, + TypecheckedHsExpr, + [Id], -- always empty (matches typecheckStmt) + Type)) + +typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls) + = typecheck dflags syn_map pcs hst unqual $ + + -- use the default default settings, i.e. [Integer, Double] + tcSetDefaultTys defaultDefaultTys $ + + -- Typecheck the extra declarations + fixTc (\ ~(unf_env, _, _, _, _) -> + tcImports unf_env pcs hst get_fixity this_mod decls + ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) -> + ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules ) + + -- Now typecheck the expression + tcSetEnv env $ + tcExtendGlobalTypeEnv ic_type_env $ + + newTyVarTy openTypeKind `thenTc` \ ty -> + tcMonoExpr expr ty `thenTc` \ (e', lie) -> + tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie + `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) -> + tcSimplifyTop lie_free `thenTc` \ const_binds -> + + let all_expr = mkHsLet const_binds $ + TyLam qtvs $ + DictLam dict_ids $ + mkHsLet dict_binds $ + e' + + all_expr_ty = mkForAllTys qtvs $ + mkFunTys (map idType dict_ids) $ + ty + in + + zonkExpr all_expr `thenNF_Tc` \ zonked_expr -> + zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty -> + ioToTc (dumpIfSet_dyn dflags + Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_` + returnTc (new_pcs, zonked_expr, [], zonked_ty) + + where + get_fixity :: Name -> Maybe Fixity + get_fixity n = pprPanic "typecheckExpr" (ppr n) + + smpl_doc = ptext SLIT("main expression") +\end{code} %************************************************************************ %* * -- 1.7.10.4