From: simonmar Date: Thu, 1 Feb 2001 11:49:32 +0000 (+0000) Subject: [project @ 2001-02-01 11:49:32 by simonmar] X-Git-Tag: Approximately_9120_patches~2757 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=31853d3e7c35881c0134ac26c78f7282306b5aba;p=ghc-hetmet.git [project @ 2001-02-01 11:49:32 by simonmar] Fix two bugs: - the typechecker wasn't attempting to resolve all the overloading when forcing an expression to IO type. Now typing '1' at the prompt works again. - the typechecker was attempting to check for Main.main even when we had avoided recompilation of Main. --- diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 5ae2e61..1179e8f 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -145,8 +145,7 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch } | otherwise = do { - hPutStr stderr "compilation IS NOT required"; - when (verbosity dflags /= 1) $ hPutStrLn stderr ""; + hPutStrLn stderr "compilation IS NOT required"; -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) @@ -157,7 +156,8 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch -- TYPECHECK maybe_tc_result <- typecheckModule dflags pcs_cl hst - old_iface alwaysQualify cl_hs_decls; + old_iface alwaysQualify cl_hs_decls + False{-don't check for Main.main-}; case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); Just (pcs_tc, tc_result) -> do { @@ -175,10 +175,7 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch = do { ; when (verbosity dflags >= 1) $ - hPutStr stderr "compilation IS required"; - -- mode -v1 tries to keep everything on one line - when (verbosity dflags > 1) $ - hPutStrLn stderr ""; + hPutStrLn stderr "compilation IS required"; -- what target are we shooting for? ; let toInterp = dopt_HscLang dflags == HscInterpreted @@ -200,7 +197,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch <- _scc_ "Rename" renameModule dflags hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { - Nothing -> return (HscFail pcs_rn); + Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do { -- In interactive mode, we don't want to discard any top-level entities at @@ -217,9 +214,10 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ------------------- ; maybe_tc_result <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface - print_unqualified rn_hs_decls + print_unqualified rn_hs_decls + True{-check for Main.main if necessary-} ; case maybe_tc_result of { - Nothing -> return (HscFail pcs_rn); + Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); Just (pcs_tc, tc_result) -> do { ; let env_tc = tc_env tc_result @@ -298,6 +296,7 @@ myParseModule dflags src_filename loc = mkSrcLoc (_PK_ src_filename) 1 } of { PFailed err -> do { hPutStrLn stderr (showSDoc err); + freeStringBuffer buf; return Nothing }; POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do { @@ -308,6 +307,7 @@ myParseModule dflags src_filename (ppSourceStats False rdr_module) ; return (Just rdr_module) + -- ToDo: free the string buffer later. }} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 631167b..2899ea8 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -62,7 +62,6 @@ import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, TyThing(..), implicitTyThingIds, mkTypeEnv ) -import IOExts \end{code} Outside-world interface: @@ -86,14 +85,15 @@ typecheckModule -> ModIface -- Iface for this module -> PrintUnqualified -- For error printing -> [RenamedHsDecl] + -> Bool -- True <=> check for Main.main if Module==Main -> IO (Maybe (PersistentCompilerState, TcResults)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module) -typecheckModule dflags pcs hst mod_iface unqual decls +typecheckModule dflags pcs hst mod_iface unqual decls check_main = do { maybe_tc_result <- typecheck dflags pcs hst unqual $ - tcModule pcs hst get_fixity this_mod decls + tcModule pcs hst get_fixity this_mod decls check_main ; printTcDump dflags maybe_tc_result ; return maybe_tc_result } where @@ -123,19 +123,9 @@ typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls) ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules ) tcSetEnv env $ - tc_expr expr `thenTc` \ (expr', lie, expr_ty) -> - tcSimplifyInfer smpl_doc - (varSetElems (tyVarsOfType expr_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 $ - expr' - all_expr_ty = mkForAllTys qtvs (mkFunTys (map idType dict_ids) expr_ty) - in - zonkExpr all_expr `thenNF_Tc` \ zonked_expr -> - zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty -> + tc_expr expr `thenTc` \ (expr', expr_ty) -> + zonkExpr expr' `thenNF_Tc` \ zonked_expr -> + zonkTcType 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) @@ -154,8 +144,19 @@ typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls) (tc_io_expr e) -- Main case | otherwise = newTyVarTy openTypeKind `thenTc` \ ty -> tcMonoExpr e ty `thenTc` \ (e', lie) -> - returnTc (e', lie, ty) - + 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 + returnTc (all_expr, all_expr_ty) where tc_io_expr e = newTyVarTy openTypeKind `thenTc` \ ty -> tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> @@ -163,7 +164,9 @@ typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls) res_ty = mkTyConApp ioTyCon [ty] in tcMonoExpr e res_ty `thenTc` \ (e', lie) -> - returnTc (e', lie, res_ty) + tcSimplifyTop lie `thenTc` \ const_binds -> + let all_expr = mkHsLet const_binds e' in + returnTc (all_expr, res_ty) --------------- typecheck :: DynFlags @@ -195,9 +198,10 @@ tcModule :: PersistentCompilerState -> (Name -> Maybe Fixity) -> Module -> [RenamedHsDecl] + -> Bool -- True <=> check for Main.main if Mod==Main -> TcM (PersistentCompilerState, TcResults) -tcModule pcs hst get_fixity this_mod decls +tcModule pcs hst get_fixity this_mod decls check_main = -- Type-check the type and class decls, and all imported decls -- tcImports recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade @@ -248,7 +252,9 @@ tcModule pcs hst get_fixity this_mod decls tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED - tcCheckMain this_mod `thenTc_` + (if check_main + then tcCheckMain this_mod + else returnTc ()) `thenTc_` -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification.