+import IO ( stdout )
+import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
+ PackageTypeEnv, ModIface(..),
+ ModDetails(..), DFunId,
+ TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
+ mkTypeEnv
+ )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The stmt interface}
+%* *
+%************************************************************************
+
+\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)
+ -> (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 (stmt, iface_decls)
+ = typecheck dflags 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 iface_decls
+ ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+ ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
+
+ tcSetEnv env $
+ tcExtendGlobalTypeEnv ic_type_env $
+
+ -- The real work is done here
+ tcUserStmt names stmt `thenTc` \ (expr, bound_ids) ->
+
+ traceTc (text "tcs 1") `thenNF_Tc_`
+ zonkExpr expr `thenNF_Tc` \ zonked_expr ->
+ mapNF_Tc zonkIdBndr bound_ids `thenNF_Tc` \ zonked_ids ->
+
+ 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, error "typecheckStmt: no type")
+
+ where
+ get_fixity :: Name -> Maybe Fixity
+ get_fixity n = pprPanic "typecheckStmt" (ppr n)
+\end{code}
+
+Here is the grand plan, implemented in tcUserStmt
+
+ What you type The IO [HValue] that hscStmt returns
+ ------------- ------------------------------------
+ let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ expr (of IO type) ==> expr >>= \ v -> return [v]
+ [NB: result not printed] bindings: [it]
+
+
+ expr (of non-IO type,
+ result showable) ==> let v = expr in print v >> return [v]
+ bindings: [it]
+
+ expr (of non-IO type,
+ result not showable) ==> error
+
+
+\begin{code}
+tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
+
+tcUserStmt names (ExprStmt expr _ loc)
+ = ASSERT( null names )
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ let
+ fresh_it = itName uniq
+ the_bind = FunMonoBind fresh_it False
+ [ mkSimpleMatch [] expr placeHolderType loc ] loc
+ in
+ tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
+ tc_stmts [fresh_it] [
+ LetStmt (MonoBind the_bind [] NonRecursive),
+ ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
+ ( traceTc (text "tcs 1a") `thenNF_Tc_`
+ tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
+
+tcUserStmt names stmt
+ = tc_stmts names [stmt]
+
+
+tc_stmts names stmts
+ = tcLookupGlobalId returnIOName `thenNF_Tc` \ return_id ->
+ tcLookupGlobalId bindIOName `thenNF_Tc` \ bind_id ->
+ tcLookupGlobalId failIOName `thenNF_Tc` \ fail_id ->
+ tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty ->
+ let
+ io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
+
+ -- mk_return builds the expression
+ -- returnIO @ [()] [coerce () x, .., coerce () z]
+ mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
+ (ExplicitList unitTy (map mk_item ids))
+
+ mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
+ (HsVar id)
+ in
+
+ traceTc (text "tcs 2") `thenNF_Tc_`
+ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts (
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+ mapNF_Tc tcLookupId names `thenNF_Tc` \ ids ->
+ returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
+ ) `thenTc` \ ((ids, tc_stmts), lie) ->
+
+ -- Simplify the context right here, so that we fail
+ -- if there aren't enough instances. Notably, when we see
+ -- e
+ -- we use tryTc_ to try it <- e
+ -- and then let it = e
+ -- It's the simplify step that rejects the first.
+
+ traceTc (text "tcs 3") `thenNF_Tc_`
+ tcSimplifyTop lie `thenTc` \ const_binds ->
+ traceTc (text "tcs 4") `thenNF_Tc_`
+
+ returnTc (mkHsLet const_binds $
+ HsDoOut DoExpr tc_stmts return_id bind_id fail_id
+ (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
+ ids)
+ where
+ 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
+ -> (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 (expr, decls)
+ = typecheck dflags 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 (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}
+
+%************************************************************************
+%* *
+\subsection{Typechecking extra declarations}
+%* *
+%************************************************************************