Commit 920d0d7e authored by simonmar's avatar simonmar

[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.
parent 435b1086
......@@ -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)
......
......@@ -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)
......
......@@ -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}
%************************************************************************
%* *
......
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