import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
-import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
+import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags ( opt_PprStyle_Debug )
import Packages ( moduleToPackageConfig, mkPackageId, package,
isHomeModule )
-import DriverState ( v_MainModIs, v_MainFunIs )
import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
nlHsApp, nlHsVar, pprLHsBinds )
import RdrHsSyn ( findSplice )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import VarEnv ( varEnvElts )
import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
- GhciMode(..), IsBootInterface, noDependencies,
+ IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
TypeEnv, lookupTypeEnv, hptInstances, lookupType,
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
LStmt, LHsExpr, LHsType, mkMatchGroup,
collectStmtsBinders, mkSimpleMatch,
- nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
+ mkExprStmt, mkBindStmt, nlVarPat )
import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
Provenance(..), ImportSpec(..),
lookupLocalRdrEnv, extendLocalRdrEnv )
isUnLiftedType, tyClsNamesOfDFunHead )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
-import Inst ( tcStdSyntaxName, tcGetInstEnvs )
+import Inst ( tcGetInstEnvs )
import InstEnv ( DFunId, classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
checkMain
= do { ghci_mode <- getGhciMode ;
tcg_env <- getGblEnv ;
-
- mb_main_mod <- readMutVar v_MainModIs ;
- mb_main_fn <- readMutVar v_MainFunIs ;
- let { main_mod = case mb_main_mod of {
+ dflags <- getDOpts ;
+ let { main_mod = case mainModIs dflags of {
Just mod -> mkModule mod ;
Nothing -> mAIN } ;
- main_fn = case mb_main_fn of {
+ main_fn = case mainFunIs dflags of {
Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
\begin{code}
---------------------------
tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L _ (ExprStmt expr _))
+tcUserStmt (L loc (ExprStmt expr _))
= newUnique `thenM` \ uniq ->
let
fresh_it = itName uniq
in
tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
- tc_stmts [
- nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
- nlExprStmt (nlHsApp (nlHsVar printName)
- (nlHsVar fresh_it))
- ] })
+ tc_stmts (map (L loc) [
+ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
+ mkExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
+ ]) })
(do { -- Try this first
traceTc (text "tcs 1a") ;
- tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
+ tc_stmts [L loc (mkBindStmt (nlVarPat fresh_it) expr)] })
tcUserStmt stmt = tc_stmts [stmt]
---------------------------
+tc_stmts :: [Stmt RdrName] ->
tc_stmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
let {
names = map unLoc (collectStmtsBinders stmts) ;
stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = infer_rhs,
+ sc_bind = infer_rhs,
+ sc_expr = infer_rhs,
sc_body = check_body,
sc_ty = ret_ty } ;
- infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
- ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
- ; return (rhs', pat_ty) } ;
+ infer_rhs _bind_op rhs
+ = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
+ ; return (noSyntaxExpr, rhs', pat_ty) } ;
+
check_body body = tcCheckRho body io_ret_ty ;
-- mk_return builds the expression
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((ids, tc_expr), lie) <- getLIE $ do {
- (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
+ (tc_stmts, ids) <- tcStmtsAndThen combine stmt_ctxt stmts $
do {
-- Look up the names right in the middle,
-- where they will all be in scope
ids <- mappM tcLookupId names ;
- ret_id <- tcLookupId returnIOName ; -- return @ IO
- return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
+ return ids } ;
- io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
- return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
+ return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty))
} ;
-- Simplify the context right here, so that we fail
\begin{code}
getModuleContents
:: HscEnv
- -> InteractiveContext
-> Module -- Module to inspect
-> Bool -- Grab just the exports, or the whole toplev
-> IO (Maybe [IfaceDecl])
-getModuleContents hsc_env ictxt mod exports_only
+getModuleContents hsc_env mod exports_only
= initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
where
get_mod_contents exports_only
; thing <- tcLookupGlobal main_name
; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
- ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
+ ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env))
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
-- Look up a RdrName and return all the TyThings it might be
-- A capitalised RdrName is given to us in the DataName namespace,
-- but we want to treat it as *both* a data constructor
--- *and* as a type or class constructor;
+-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env ictxt rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
projects / ghc-hetmet.git / blobdiff