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
#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
-----------------------------------------------------------------------------
(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
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)
import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE )
import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
writeIface, pprIface )
+import Type ( Type )
import TcModule
import InstEnv ( emptyInstEnv )
import Desugar
-> 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
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,
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
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
= 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)
\begin{code}
module TcModule (
- typecheckModule, typecheckIface, typecheckStmt, TcResults(..)
+ typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
+ TcResults(..)
) where
#include "HsVersions.h"
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,
)
+import TcExpr ( tcMonoExpr )
import TcMonad
import TcType ( newTyVarTy, zonkTcType, tcInstType )
import TcMatches ( tcStmtsAndThen )
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 )
%************************************************************************
\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 $
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
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}
%************************************************************************
%* *
projects / ghc-hetmet.git / commitdiff