X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=60d1d9556974702b56befbf420348cb938f22a49;hb=ce42f19f8c840fbe89844471a0d850d310a94556;hp=bd65fc42cd1111a92ced2a078b41618d87ae7136;hpb=16e4ce4c0c02650082f2e11982017c903c549ad5;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index bd65fc4..60d1d95 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -22,7 +22,6 @@ import DsMeta ( templateHaskellNames ) import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) -import DriverUtil ( split_longest_prefix ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), HsGroup(..), SpliceDecl(..), @@ -32,11 +31,10 @@ import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, - returnIOName, bindIOName, failIOName, thenIOName, runIOName, - dollarMainName, itName, mAIN_Name, unsafeCoerceName +import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, + returnIOName, runIOName, + rootMainName, itName, mAIN_Name ) -import MkId ( unsafeCoerceId ) import RdrName ( RdrName, getRdrName, mkRdrUnqual, lookupRdrEnv, elemRdrEnv ) @@ -49,13 +47,12 @@ import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, import TcExpr ( tcInferRho, tcCheckRho ) import TcRnMonad -import TcMType ( newTyVarTy, zonkTcType ) -import TcType ( Type, liftedTypeKind, +import TcType ( Type, tyVarsOfType, tcFunResultTy, tidyTopType, mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys ) -import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) -import Inst ( showLIE ) +import Inst ( showLIE, tcStdSyntaxName ) +import MkId ( unsafeCoerceId ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) @@ -68,7 +65,7 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds ) import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) +import TcSimplify ( tcSimplifyTop, tcSimplifyInteractive, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, @@ -77,25 +74,20 @@ import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) import RnHiFiles ( readIface, loadOldIface ) import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) -import RnExpr ( rnStmts, rnExpr ) import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) import CoreUnfold ( unfoldingTemplate ) import CoreSyn ( IdCoreRule, Bind(..) ) import PprCore ( pprIdRules, pprCoreBindings ) -import TysWiredIn ( mkListTy, unitTy ) import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors ) import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported ) -import IdInfo ( GlobalIdDetails(..) ) import Var ( Var, setGlobalIdDetails ) -import Module ( Module, ModuleName, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts ) +import Module ( Module, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts ) import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, nameOccName ) -import NameEnv ( delListFromNameEnv ) import NameSet import TyCon ( tyConGenInfo ) import BasicTypes ( EP(..), RecFlag(..) ) -import SrcLoc ( noSrcLoc ) import Outputable import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), ModIface, ModDetails(..), ModGuts(..), @@ -111,14 +103,20 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), extendLocalRdrEnv, emptyFixityEnv ) #ifdef GHCI +import TcMType ( zonkTcType ) +import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) import RdrName ( rdrEnvElts ) +import RnExpr ( rnStmts, rnExpr ) import RnHiFiles ( loadInterface ) import RnEnv ( mkGlobalRdrEnv ) +import TysWiredIn ( mkListTy, unitTy ) +import IdInfo ( GlobalIdDetails(..) ) +import SrcLoc ( noSrcLoc ) +import NameEnv ( delListFromNameEnv ) import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), isLocalGRE ) #endif -import DATA_IOREF ( readIORef ) import FastString ( mkFastString ) import Panic ( showException ) import List ( partition ) @@ -297,7 +295,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt setGblEnv tcg_env $ do { -- The real work is done here - ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ; + (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; traceTc (text "tcs 1") ; let { -- Make all the bound ids "global" ids, now that @@ -384,8 +382,10 @@ tcUserStmt stmt = tc_stmts [stmt] tc_stmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; let { - ret_ty = mkListTy unitTy ; - names = collectStmtsBinders stmts ; + ret_ty = mkListTy unitTy ; + io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + + names = collectStmtsBinders stmts ; stmt_ctxt = SC { sc_what = DoExpr, sc_rhs = check_rhs, @@ -393,29 +393,41 @@ tc_stmts stmts sc_ty = ret_ty } ; check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; - check_body body = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ; + check_body body = tcCheckRho body io_ret_ty ; - -- ret_expr is the expression - -- returnIO [coerce () x, .., coerce () z] - ret_stmt = ResultStmt ret_expr noSrcLoc ; - ret_expr = HsApp (HsVar returnIOName) - (ExplicitList placeHolderType (map mk_item names)) ; - mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ; - - all_stmts = stmts ++ [ret_stmt] + -- mk_return builds the expression + -- returnIO @ [()] [coerce () x, .., coerce () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + mk_return ret_id ids = HsApp (TyApp (HsVar ret_id) [ret_ty]) + (ExplicitList unitTy (map mk_item ids)) ; + mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy]) + (HsVar id) ; + + io_ty = mkTyConApp ioTyCon [] } ; -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; - ((ids, tc_stmts), lie) <- - getLIE $ - 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 ; - return (ids, []) - } ; + ((ids, tc_expr), lie) <- getLIE $ do { + (ids, tc_stmts) <- 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, [ResultStmt (mk_return ret_id ids) noSrcLoc]) } ; + + io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; + return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty noSrcLoc) + } ; -- Simplify the context right here, so that we fail -- if there aren't enough instances. Notably, when we see @@ -424,14 +436,10 @@ tc_stmts stmts -- and then let it = e -- It's the simplify step that rejects the first. traceTc (text "tcs 3") ; - const_binds <- tcSimplifyTop lie ; + const_binds <- tcSimplifyInteractive lie ; -- Build result expression and zonk it - io_ids <- mappM mk_rebound - [returnIOName, failIOName, bindIOName, thenIOName] ; - let { expr = mkHsLet const_binds $ - HsDo DoExpr tc_stmts io_ids - (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ; + let { expr = mkHsLet const_binds tc_expr } ; zonked_expr <- zonkTopExpr expr ; zonked_ids <- zonkTopBndrs ids ; @@ -439,8 +447,6 @@ tc_stmts stmts } where combine stmt (ids, stmts) = (ids, stmt:stmts) - mk_rebound n = do { id <- tcLookupId n; return (n, HsVar id) } - -- A bit hackoid \end{code} @@ -466,7 +472,7 @@ tcRnExpr hsc_env pcs ictxt rdr_expr -- it might have a rank-2 type (e.g. :t runST) ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; - tcSimplifyTop lie_top ; + tcSimplifyInteractive lie_top ; let { all_expr_ty = mkForAllTys qtvs $ mkFunTys (map idType dict_ids) $ @@ -484,8 +490,10 @@ tcRnThing :: HscEnv -> PersistentCompilerState -> RdrName -> IO (PersistentCompilerState, Maybe [TyThing]) -- Look up a RdrName and return all the TyThings it might be --- We treat a capitalised RdrName as both a data constructor --- and as a type or class constructor; hence we return up to two results +-- 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; +-- hence the call to dataTcOccs, and we return up to two results tcRnThing hsc_env pcs ictxt rdr_name = initTc hsc_env pcs iNTERACTIVE $ setInteractiveContext ictxt $ do { @@ -505,7 +513,12 @@ tcRnThing hsc_env pcs ictxt rdr_name errs_s = [msgs | (msgs, Nothing) <- results] } ; -- Fail if nothing good happened, else add warnings - if null good_names then -- Fail + if null good_names then + -- No lookup succeeded, so + -- pick the first error message and report it + -- ToDo: If one of the errors is "could be Foo.X or Baz.X", + -- while the other is "X is not in scope", + -- we definitely want the former; but we might pick the latter do { addMessages (head errs_s) ; failM } else -- Add deprecation warnings mapM_ addMessages warns_s ; @@ -534,7 +547,7 @@ initRnInteractive ictxt rn_thing = initRn CmdLineMode $ setLocalRdrEnv (ic_rn_local_env ictxt) $ rn_thing -#endif +#endif /* GHCI */ \end{code} %************************************************************************ @@ -561,13 +574,13 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) -- rnSrcDecls handles fixity decls etc too, which won't occur -- but that doesn't matter let { local_group = mkGroup decls } ; - (_, rn_decls, dus) <- initRn (InterfaceMode this_mod) - (rnSrcDecls local_group) ; + (_, rn_src_decls, dus) <- initRn (InterfaceMode this_mod) + (rnSrcDecls local_group) ; failIfErrsM ; -- Get the supporting decls rn_imp_decls <- slurpImpDecls (duUses dus) ; - let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ; + let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; @@ -1164,12 +1177,12 @@ check_main ghci_mode tcg_env main_mod main_fn addErrCtxt mainCtxt $ setGblEnv tcg_env $ do { - -- $main :: IO () = runIO main + -- :Main.main :: IO () = runIO main let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; (main_expr, ty) <- tcInferRho rhs ; - let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ; - main_bind = VarMonoBind dollar_main_id main_expr ; + let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; + main_bind = VarMonoBind root_main_id main_expr ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` main_bind } } ;