X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=6850846950419426b1013b8ba204d5809691240e;hp=88695bcf9dd96526cf46eb418f550a027c65dab7;hb=HEAD;hpb=e1cae1230d5b334c045d0c568d5bf7d02a26dbd7 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 88695bc..6850846 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -2,30 +2,23 @@ % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcModule]{Typechecking a whole module} +\section[TcMovectle]{Typechecking a whole module} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, + getModuleExports, +#endif + tcRnImports, tcRnLookupName, tcRnGetInfo, - getModuleExports, -#endif tcRnModule, tcTopSrcDecls, tcRnExtCore ) where -import IO #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif @@ -33,35 +26,33 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags import StaticFlags import HsSyn -import RdrHsSyn - import PrelNames import RdrName import TcHsSyn import TcExpr import TcRnMonad -import TcType -import Inst +import Coercion import FamInst import InstEnv import FamInstEnv +import TcAnnotations import TcBinds +import TcType ( tidyTopType ) import TcDefaults import TcEnv import TcRules import TcForeign import TcInstDcls import TcIface +import TcMType import MkIface import IfaceSyn import TcSimplify import TcTyClsDecls -import TcUnify ( withBox ) import LoadIface import RnNames import RnEnv import RnSource -import RnHsDoc import PprCore import CoreSyn import ErrUtils @@ -69,12 +60,11 @@ import Id import VarEnv import Var import Module -import LazyUniqFM +import UniqFM import Name import NameEnv import NameSet import TyCon -import TysWiredIn import SrcLoc import HscTypes import ListSetOps @@ -82,21 +72,22 @@ import Outputable import DataCon import Type import Class +import TcType ( orphNamesOfDFunHead ) +import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) #ifdef GHCI -import Linker +import TcType ( isUnitTy, isTauTy ) +import CoreUtils( mkPiTypes ) import TcHsType -import TcMType import TcMatches import RnTypes import RnExpr import IfaceEnv import MkId -import IdInfo -import {- Kind parts of -} Type import BasicTypes -import Foreign.Ptr( Ptr ) +import TidyPgm ( globaliseAndTidyId ) +import TysWiredIn ( unitTy, mkListTy ) #endif import FastString @@ -105,13 +96,10 @@ import Util import Bag import Control.Monad -import Data.Maybe ( isJust ) #include "HsVersions.h" \end{code} - - %************************************************************************ %* * Typecheck and rename a module @@ -129,7 +117,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec - module_info maybe_doc)) + maybe_doc_hdr)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; @@ -168,26 +156,31 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- thing (especially via 'module Foo' export item) -- That is, only uses in the *body* of the module are complained about traceRn (text "rn3") ; - failIfErrsM ; -- finishDeprecations crashes sometimes + failIfErrsM ; -- finishWarnings crashes sometimes -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; + tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; traceRn (text "rn4b: after exportss") ; + -- Check that main is exported (must be after rnExports) + checkMainExported tcg_env ; + -- Compare the hi-boot iface (if any) with the real thing -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- Make the new type env available to stuff slurped from interface files - -- Must do this after checkHiBootIface, because the latter might add new - -- bindings for boot_dfuns, which may be mentioned in imported unfoldings - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings - -- Rename the Haddock documentation - tcg_env <- rnHaddock module_info maybe_doc tcg_env ; + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; -- Report unused names reportUnusedNames export_ies tcg_env ; @@ -234,7 +227,7 @@ tcRnImports hsc_env this_mod import_decls gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), + tcg_rn_imports = rn_imports, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, @@ -252,9 +245,8 @@ tcRnImports hsc_env this_mod import_decls -- interfaces, so that their rules and instance decls will be -- found. ; loadOrphanModules (imp_orphs imports) False - ; loadOrphanModules (imp_finsts imports) True - -- Check type-familily consistency + -- Check type-family consistency ; traceRn (text "rn1: checking family instance consistency") ; let { dir_imp_mods = moduleEnvKeys . imp_mods @@ -293,22 +285,23 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- (in fact, it might not even need to be in the scope of -- this tcg_env at all) avails <- getLocalNonValBinders (mkFakeGroup ldecls) ; - tc_envs <- extendGlobalRdrEnvRn False avails - emptyFsEnv {- no fixity decls -} ; + tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ; setEnvs tc_envs $ do { - rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; + (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; - -- Make the new type env available to stuff slurped from interface files + -- Just discard the auxiliary bindings; they are generated + -- only for Haskell source code, and should already be in Core + (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { + -- Make the new type env available to stuff slurped from interface files -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; @@ -319,7 +312,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? - final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; + final_type_env = + extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; mod_guts = ModGuts { mg_module = this_mod, mg_boot = False, @@ -333,12 +327,14 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], + mg_vect_decls = [], + mg_anns = [], mg_binds = core_binds, -- Stubs mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, - mg_deprecs = NoDeprecs, + mg_warns = NoWarnings, mg_foreign = NoStubs, mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, @@ -350,8 +346,9 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) return mod_guts }}}} +mkFakeGroup :: [LTyClDecl a] -> HsGroup a mkFakeGroup decls -- Rather clumsy; lots of unused fields - = emptyRdrGroup { hs_tyclds = decls } + = emptyRdrGroup { hs_tyclds = [decls] } \end{code} @@ -367,11 +364,14 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls = do { -- Do all the declarations - (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ; + (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; + ; traceTc "Tc8" empty ; + ; setEnvs tc_envs $ + do { -- Finish simplifying class constraints -- - -- tcSimplifyTop deals with constant or ambiguous InstIds. + -- simplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a -- top-level decl falls under the monomorphism restriction -- and no subsequent decl instantiates its type. @@ -380,40 +380,49 @@ tcRnSrcDecls boot_iface decls -- thaat checkMain adds -- -- We do it with both global and local env in scope: - -- * the global env exposes the instances to tcSimplifyTop - -- * the local env exposes the local Ids to tcSimplifyTop, + -- * the global env exposes the instances to simplifyTop + -- * the local env exposes the local Ids to simplifyTop, -- so that we get better error messages (monomorphism restriction) - traceTc (text "Tc8") ; - inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; - - -- Backsubstitution. This must be done last. - -- Even tcSimplifyTop may do some unification. - traceTc (text "Tc9") ; - let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env - ; all_binds = binds `unionBags` inst_binds } ; + new_ev_binds <- simplifyTop lie ; + traceTc "Tc9" empty ; failIfErrsM ; -- Don't zonk if there have been errors -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! - (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; - - let { final_type_env = extendTypeEnvWithIds type_env bind_ids - ; tcg_env' = tcg_env { tcg_type_env = final_type_env, - tcg_binds = binds', - tcg_rules = rules', - tcg_fords = fords' } } ; - - return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) - } + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_vects = vects, + tcg_fords = fords } = tcg_env + ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; + + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ; + + let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; tcg_env' = tcg_env { tcg_binds = binds', + tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', + tcg_rules = rules', + tcg_vects = vects', + tcg_fords = fords' } } ; + + setGlobalTypeEnv tcg_env' final_type_env + } } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds - = do { let { (first_group, group_tail) = findSplice ds } ; + = do { (first_group, group_tail) <- findSplice ds ; -- If ds is [] we get ([], Nothing) -- Deal with decls up to, but not including, the first splice @@ -430,11 +439,13 @@ tc_rn_src_decls boot_details ds return (tcg_env, tcl_env) } ; - -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr, rest_ds) -> do { #ifndef GHCI + -- There shouldn't be a splice + Just (SpliceDecl {}, _) -> do { failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else + -- If there's a splice, we must carry on + Just (SpliceDecl splice_expr _, rest_ds) -> do { -- Rename the splice expression, and get its supporting decls (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; @@ -461,51 +472,76 @@ tc_rn_src_decls boot_details ds \begin{code} tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls - = do { let { (first_group, group_tail) = findSplice decls } - - ; case group_tail of - Just stuff -> spliceInHsBootErr stuff - Nothing -> return () + = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations - ; (tcg_env, rn_group) <- rnTopSrcDecls first_group - ; setGblEnv tcg_env $ do { + ; (tcg_env, HsGroup { + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = for_decls, + hs_defds = def_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls first_group + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { + - -- Todo: check no foreign decls, no rules, no default decls + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl d _, _) -> badBootDecl "splice" d + Nothing -> return () + ; mapM_ (badBootDecl "foreign") for_decls + ; mapM_ (badBootDecl "default") def_decls + ; mapM_ (badBootDecl "rule") rule_decls + ; mapM_ (badBootDecl "vect") vect_decls -- Typecheck type/class decls - ; traceTc (text "Tc2") - ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { + ; traceTc "Tc2" empty + ; (tcg_env, aux_binds) + <- tcTyAndClassDecls emptyModDetails tycl_decls + ; setGblEnv tcg_env $ do { -- Typecheck instance decls - ; traceTc (text "Tc3") + -- Family instance declarations are rejected here + ; traceTc "Tc3" empty ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group) + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls + ; setGblEnv tcg_env $ do { -- Typecheck value declarations - ; traceTc (text "Tc5") - ; val_ids <- tcHsBootSigs (hs_valds rn_group) + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds -- Wrap up -- No simplification or zonking to do - ; traceTc (text "Tc7a") + ; traceTc "Tc7a" empty ; gbl_env <- getGblEnv -- Make the final type-env -- Include the dfun_ids so that their type sigs - -- are written into the interface file + -- are written into the interface file. + -- And similarly the aux_ids from aux_binds ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos } - ; return (gbl_env { tcg_type_env = type_env2 }) - }}}} - -spliceInHsBootErr (SpliceDecl (L loc _), _) - = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files")) + ; type_env3 = extendTypeEnvWithIds type_env2 aux_ids + ; dfun_ids = map iDFunId inst_infos + ; aux_ids = case aux_binds of + ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs] + _ -> panic "tcRnHsBoodDecls" + } + + ; setGlobalTypeEnv gbl_env type_env3 + }}} + ; traceTc "boot" (ppr lie); return gbl_env } + +badBootDecl :: String -> Located decl -> TcM () +badBootDecl what (L loc _) + = addErrAt loc (char 'A' <+> text what + <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file")) \end{code} Once we've typechecked the body of the module, we want to compare what @@ -523,7 +559,7 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv checkHiBootIface tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, - tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + tcg_insts = local_insts, tcg_type_env = local_type_env, tcg_exports = local_exports }) (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, md_types = boot_type_env, md_exports = boot_exports }) @@ -531,21 +567,12 @@ checkHiBootIface = return tcg_env | otherwise - = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$ - ppr boot_exports)) ; + = do { traceTc "checkHiBootIface" $ vcat + [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts - ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, - tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } - dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -554,8 +581,21 @@ checkHiBootIface -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + type_env' = extendTypeEnvWithIds local_type_env boot_dfuns + tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + ; failIfErrsM - ; return tcg_env' } + ; setGlobalTypeEnv tcg_env' type_env' } + -- Update the global type env *including* the knot-tied one + -- so that if the source module reads in an interface unfolding + -- mentioning one of the dfuns from the boot module, then it + -- can "see" that boot dfun. See Trac #4003 where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -602,8 +642,12 @@ checkHiBootIface check_inst boot_inst = case [dfun | inst <- local_insts, let dfun = instanceDFunId inst, - idType dfun `tcEqType` boot_inst_ty ] of - [] -> do { addErrTc (instMisMatch boot_inst); return Nothing } + idType dfun `eqType` boot_inst_ty ] of + [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) + , text "boot_inst" <+> ppr boot_inst + , text "boot_inst_ty" <+> ppr boot_inst_ty + ]) + ; addErrTc (instMisMatch boot_inst); return Nothing } (dfun:_) -> return (Just (local_boot_dfun, dfun)) where boot_dfun = instanceDFunId boot_inst @@ -622,34 +666,87 @@ checkBootDecl :: TyThing -> TyThing -> Bool checkBootDecl (AnId id1) (AnId id2) = ASSERT(id1 == id2) - (idType id1 `tcEqType` idType id2) + (idType id1 `eqType` idType id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) + = checkBootTyCon tc1 tc2 + +checkBootDecl (AClass c1) (AClass c2) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = classExtraBigSig c1 + (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + = classExtraBigSig c2 + + env0 = mkRnEnv2 emptyInScopeSet + env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2 + + eqSig (id1, def_meth1) (id2, def_meth2) + = idName id1 == idName id2 && + eqTypeX env op_ty1 op_ty2 && + def_meth1 == def_meth2 + where + (_, rho_ty1) = splitForAllTys (idType id1) + op_ty1 = funResultTy rho_ty1 + (_, rho_ty2) = splitForAllTys (idType id2) + op_ty2 = funResultTy rho_ty2 + + eqFD (as1,bs1) (as2,bs2) = + eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + + same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2) + in + eqListBy same_kind clas_tyvars1 clas_tyvars2 && + -- Checks kind of class + eqListBy eqFD clas_fds1 clas_fds2 && + (null sc_theta1 && null op_stuff1 && null ats1 + || -- Above tests for an "abstract" class + eqListBy (eqPredX env) sc_theta1 sc_theta2 && + eqListBy eqSig op_stuff1 op_stuff2 && + eqListBy checkBootTyCon ats1 ats2) + +checkBootDecl (ADataCon dc1) (ADataCon _) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ = False -- probably shouldn't happen + +---------------- +checkBootTyCon :: TyCon -> TyCon -> Bool +checkBootTyCon tc1 tc2 + | not (eqKind (tyConKind tc1) (tyConKind tc2)) + = False -- First off, check the kind + | isSynTyCon tc1 && isSynTyCon tc2 = ASSERT(tc1 == tc2) let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 env = rnBndrs2 env0 tvs1 tvs2 - eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _) - = tcEqTypeX env k1 k2 + eqSynRhs SynFamilyTyCon SynFamilyTyCon + = True eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) - = tcEqTypeX env t1 t2 + = eqTypeX env t1 t2 + eqSynRhs _ _ = False in equalLength tvs1 tvs2 && eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) | isAlgTyCon tc1 && isAlgTyCon tc2 = ASSERT(tc1 == tc2) - eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) - && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) + eqKind (tyConKind tc1) (tyConKind tc2) && + eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) && + eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) | isForeignTyCon tc1 && isForeignTyCon tc2 - = tyConExtName tc1 == tyConExtName tc2 + = eqKind (tyConKind tc1) (tyConKind tc2) && + tyConExtName tc1 == tyConExtName tc2 + + | otherwise = False where env0 = mkRnEnv2 emptyInScopeSet eqAlgRhs AbstractTyCon _ = True - eqAlgRhs OpenTyCon{} OpenTyCon{} = True + eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = eqListBy eqCon (data_cons tc1) (data_cons tc2) eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = @@ -661,63 +758,21 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2) && dataConIsInfix c1 == dataConIsInfix c2 && dataConStrictMarks c1 == dataConStrictMarks c2 && dataConFieldLabels c1 == dataConFieldLabels c2 - && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1 - tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2 - env = rnBndrs2 env0 tvs1 tvs2 - in - equalLength tvs1 tvs2 && - eqListBy (tcEqPredX env) - (dataConEqTheta c1 ++ dataConDictTheta c1) - (dataConEqTheta c2 ++ dataConDictTheta c2) && - eqListBy (tcEqTypeX env) - (dataConOrigArgTys c1) - (dataConOrigArgTys c2) - -checkBootDecl (AClass c1) (AClass c2) - = let - (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1) - = classExtraBigSig c1 - (clas_tyvars2, clas_fds2, sc_theta2, _, _, op_stuff2) - = classExtraBigSig c2 - - env0 = mkRnEnv2 emptyInScopeSet - env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2 - - eqSig (id1, def_meth1) (id2, def_meth2) - = idName id1 == idName id2 && - tcEqTypeX env op_ty1 op_ty2 - where - (_, rho_ty1) = splitForAllTys (idType id1) - op_ty1 = funResultTy rho_ty1 - (_, rho_ty2) = splitForAllTys (idType id2) - op_ty2 = funResultTy rho_ty2 - - eqFD (as1,bs1) (as2,bs2) = - eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - equalLength clas_tyvars1 clas_tyvars2 && - eqListBy eqFD clas_fds1 clas_fds2 && - (null sc_theta1 && null op_stuff1 - || - eqListBy (tcEqPredX env) sc_theta1 sc_theta2 && - eqListBy eqSig op_stuff1 op_stuff2) - -checkBootDecl (ADataCon dc1) (ADataCon dc2) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ = False -- probably shouldn't happen + && eqType (dataConUserType c1) (dataConUserType c2) ---------------- -missingBootThing thing what - = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") +missingBootThing :: Name -> String -> SDoc +missingBootThing name what + = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") <+> text what <+> ptext (sLit "the module") +bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc bootMisMatch thing boot_decl real_decl = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), ptext (sLit "Main module:") <+> ppr real_decl, ptext (sLit "Boot file: ") <+> ppr boot_decl] +instMisMatch :: Instance -> SDoc instMisMatch inst = hang (ppr inst) 2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself")) @@ -746,8 +801,10 @@ monad; it augments it and returns the new TcGblEnv. rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) -- Fails if there are any errors rnTopSrcDecls group - = do { -- Rename the source decls (with no shadowing; error on duplicates) - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ; + = do { -- Rename the source decls + traceTc "rn12" empty ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; + traceTc "rn13" empty ; -- save the renamed syntax, if we want it let { tcg_env' @@ -770,77 +827,91 @@ tcTopSrcDecls boot_details hs_derivds = deriv_decls, hs_fords = foreign_decls, hs_defds = default_decls, + hs_annds = annotation_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls - traceTc (text "Tc2") ; + traceTc "Tc2" empty ; - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - -- Make these type and class decls available to stuff slurped from interface files - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; - - setGblEnv tcg_env $ do { + -- Source-language instances, including derivings, -- and import the supporting declarations - traceTc (text "Tc3") ; + traceTc "Tc3" empty ; (tcg_env, inst_infos, deriv_binds) - <- tcInstDecls1 tycl_decls inst_decls deriv_decls; + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; setGblEnv tcg_env $ do { - -- Foreign import declarations next. No zonking necessary - -- here; we can tuck them straight into the global environment. - traceTc (text "Tc4") ; + -- Foreign import declarations next. + traceTc "Tc4" empty ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { -- Default declarations - traceTc (text "Tc4a") ; + traceTc "Tc4a" empty ; default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + (tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; + (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $ + discardWarnings (tcTopBinds deriv_binds) ; + -- Value declarations next - -- We also typecheck any extra binds that came out - -- of the "deriving" process (deriv_binds) - traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds val_binds ; - setLclTypeEnv tcl_env $ do { - - -- Now GHC-generated derived bindings and generics. - -- Do not generate warnings from compiler-generated code. - (tc_deriv_binds, tcl_env) <- discardWarnings $ - tcTopBinds deriv_binds ; - - -- Second pass over class and instance declarations, - traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; - - -- Foreign exports - -- They need to be zonked, so we return them - traceTc (text "Tc7") ; - (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; - - -- Rules - rules <- tcRules rule_decls ; + traceTc "Tc5" empty ; + (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; - -- Wrap up - traceTc (text "Tc7a") ; + setLclTypeEnv tcl_env $ do { -- Environment doesn't change now + + -- Second pass over class and instance declarations, + -- now using the kind-checked decls + traceTc "Tc6" empty ; + inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; + + -- Foreign exports + traceTc "Tc7" empty ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + + -- Annotations + annotations <- tcAnnotations annotation_decls ; + + -- Rules + rules <- tcRules rule_decls ; + + -- Vectorisation declarations + vects <- tcVectDecls vect_decls ; + + -- Wrap up + traceTc "Tc7a" empty ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` tc_deriv_binds `unionBags` + tc_aux_binds `unionBags` inst_binds `unionBags` - foe_binds ; - - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, - tcg_rules = tcg_rules tcg_env ++ rules, - tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; - return (tcg_env', tcl_env) + foe_binds + + ; sig_names = mkNameSet (collectHsValBinders val_binds) + `minusNameSet` getTypeSigNames val_binds + + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ + specs3 + , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names + , tcg_rules = tcg_rules tcg_env ++ rules + , tcg_vects = tcg_vects tcg_env ++ vects + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + return (tcg_env', tcl_env) }}}}}} \end{code} @@ -860,27 +931,28 @@ checkMain check_main dflags tcg_env } +check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv check_main dflags tcg_env | mod /= main_mod - = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> + = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> return tcg_env | otherwise - = do { mb_main <- lookupSrcOcc_maybe main_fn + = do { mb_main <- lookupGlobalOccRn_maybe main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { - Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn) + Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) ; complain_no_main ; return tcg_env } ; Just main_name -> do - { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) + { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) ; let loc = srcLocSpan (getSrcLoc main_name) ; ioTyCon <- tcLookupTyCon ioTyConName - ; (main_expr, res_ty) + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; main_expr <- addErrCtxt mainCtxt $ - withBox liftedTypeKind $ \res_ty -> tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) -- See Note [Root-main Id] @@ -894,24 +966,21 @@ check_main dflags tcg_env (mkTyConApp ioTyCon [res_ty]) ; co = mkWpTyApps [res_ty] ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = noLoc (VarBind root_main_id rhs) } + ; main_bind = mkVarBind root_main_id rhs } - ; return (tcg_env { tcg_binds = tcg_binds tcg_env + ; return (tcg_env { tcg_main = Just main_name, + tcg_binds = tcg_binds tcg_env `snocBag` main_bind, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (unitFV main_name) -- Record the use of 'main', so that we don't -- complain about it being defined but not used - }) + }) }}} where mod = tcg_mod tcg_env main_mod = mainModIs dflags - main_is_flag = mainFunIs dflags - - main_fn = case main_is_flag of - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) - Nothing -> main_RDR_Unqual + main_fn = getMainFun dflags complain_no_main | ghcLink dflags == LinkInMemory = return () | otherwise = failWithTc noMainMsg @@ -922,8 +991,32 @@ check_main dflags tcg_env mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn noMainMsg = ptext (sLit "The") <+> pp_main_fn <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) - pp_main_fn | isJust main_is_flag = ptext (sLit "main function") <+> quotes (ppr main_fn) - | otherwise = ptext (sLit "function") <+> quotes (ppr main_fn) + pp_main_fn = ppMainFn main_fn + +ppMainFn :: RdrName -> SDoc +ppMainFn main_fn + | main_fn == main_RDR_Unqual + = ptext (sLit "function") <+> quotes (ppr main_fn) + | otherwise + = ptext (sLit "main function") <+> quotes (ppr main_fn) + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainFun :: DynFlags -> RdrName +getMainFun dflags = case (mainFunIs dflags) of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual + +checkMainExported :: TcGblEnv -> TcM () +checkMainExported tcg_env = do + dflags <- getDOpts + case tcg_main tcg_env of + Nothing -> return () -- not the main module + Just main_name -> do + let main_mod = mainModIs dflags + checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ + ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> + ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) \end{code} Note [Root-main Id] @@ -946,12 +1039,11 @@ get two defns for 'main' in the interface file! %********************************************************* \begin{code} -#ifdef GHCI setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a setInteractiveContext hsc_env icxt thing_inside = let -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnModule. - (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True) + (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) in updGblEnv (\env -> env { tcg_rdr_env = ic_rn_gbl_env icxt, @@ -971,16 +1063,17 @@ setInteractiveContext hsc_env icxt thing_inside -- later ids in ic_tmp_ids must shadow earlier ones with the same -- OccName, and tcExtendIdEnv implements this behaviour. - do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt)) + do { traceTc "setIC" (ppr (ic_tmp_ids icxt)) ; thing_inside } \end{code} \begin{code} +#ifdef GHCI tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Maybe ([Id], LHsExpr Id)) + -> IO (Messages, Maybe ([Id], LHsExpr Id)) -- The returned [Id] is the list of new Ids bound by -- this statement. It can be used to extend the -- InteractiveContext via extendInteractiveContext. @@ -993,7 +1086,8 @@ tcRnStmt hsc_env ictxt rdr_stmt setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ; + (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; rnDump (ppr rn_stmt) ; @@ -1005,11 +1099,12 @@ tcRnStmt hsc_env ictxt rdr_stmt -- None of the Ids should be of unboxed type, because we -- cast them all to HValues in the end! - mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + + traceTc "tcs 1" empty ; + let { global_ids = map globaliseAndTidyId zonked_ids } ; + -- Note [Interactively-bound Ids in GHCi] - traceTc (text "tcs 1") ; - let { global_ids = map globaliseAndTidy zonked_ids } ; - {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; they are inaccessible but might, I suppose, cause a space leak if we leave them there. @@ -1038,12 +1133,6 @@ tcRnStmt hsc_env ictxt rdr_stmt where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -globaliseAndTidy :: Id -> Id -globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi] - = Id.setIdType (globaliseId VanillaGlobal id) tidy_type - where - tidy_type = tidyTopType (idType id) \end{code} Note [Interactively-bound Ids in GHCi] @@ -1103,7 +1192,7 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -------------------- mkPlan :: LStmt Name -> TcM PlanResult -mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt +mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt = do { uniq <- newUnique -- is treated very specially ; let fresh_it = itName uniq the_bind = L loc $ mkFunBind (L loc fresh_it) matches @@ -1112,7 +1201,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr (HsVar bindIOName) noSyntaxExpr print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: -- [it <- e; print it] but not if it::() @@ -1132,15 +1221,15 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt -- The two-step process avoids getting two errors: one from -- the expression itself, and one from the 'print it' part -- This two-step story is very clunky, alas - do { checkNoErrs (tcGhciStmts [let_stmt]) + do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) --- checkNoErrs defeats the error recovery of let-bindings ; tcGhciStmts [let_stmt, print_it] } ]} mkPlan stmt@(L loc (BindStmt {})) - | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt + | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType ; print_bind_result <- doptM Opt_PrintBindResult ; let print_plan = do @@ -1167,11 +1256,25 @@ tcGhciStmts stmts let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ; + tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; + names = collectLStmtsBinders stmts ; + } ; - names = map unLoc (collectLStmtsBinders stmts) ; + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails - -- mk_return builds the expression + traceTc "TcRnDriver.tcGhciStmts: done" empty ; + let { -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] -- -- Despite the inconvenience of building the type applications etc, @@ -1182,27 +1285,14 @@ tcGhciStmts stmts -- 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 ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) - (nlHsVar id) - } ; - - -- OK, we're ready to typecheck the stmts - traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ; - ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ; - const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc (text "TcRnDriver.tcGhciStmts: done") ; - return (ids, mkHsDictLet const_binds $ - noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + } ; + return (ids, mkHsDictLet (EvBinds const_binds) $ + noLoc (HsDo GhciStmt stmts io_ret_ty)) } \end{code} @@ -1213,27 +1303,28 @@ tcRnExpr just finds the type of an expression tcRnExpr :: HscEnv -> InteractiveContext -> LHsExpr RdrName - -> IO (Maybe Type) + -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - (rn_expr, fvs) <- rnLExpr rdr_expr ; + (rn_expr, _fvs) <- rnLExpr rdr_expr ; failIfErrsM ; -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; - ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; - tcSimplifyInteractive lie_top ; - - let { all_expr_ty = mkForAllTys qtvs $ - mkFunTys (map (idType . instToId) dict_insts) $ - res_ty } ; + uniq <- newUnique ; + let { fresh_it = itName uniq } ; + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _), lie_top) <- captureConstraints $ + simplifyInfer TopLevel False {- No MR for now -} + [(fresh_it, res_ty)] + lie ; + _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings + + let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; zonkTcType all_expr_ty } - where - smpl_doc = ptext (sLit "main expression") \end{code} tcRnType just finds the kind of a type @@ -1242,7 +1333,7 @@ tcRnType just finds the kind of a type tcRnType :: HscEnv -> InteractiveContext -> LHsType RdrName - -> IO (Maybe Kind) + -> IO (Messages, Maybe Kind) tcRnType hsc_env ictxt rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1251,7 +1342,7 @@ tcRnType hsc_env ictxt rdr_type failIfErrsM ; -- Now kind-check the type - (ty', kind) <- kcHsType rn_type ; + (_ty', kind) <- kcLHsType rn_type ; return kind } where @@ -1269,45 +1360,37 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI --- ASSUMES that the module is either in the HomePackageTable or is +-- | ASSUMES that the module is either in the 'HomePackageTable' or is -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) getModuleExports hsc_env mod - = let - ic = hsc_IC hsc_env - checkMods = ic_toplev_scope ic ++ ic_exports ic - in - initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) + = initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod) -- Get the export avail info and also load all orphan and family-instance -- modules. Finally, check that the family instances of all modules in the -- interactive context are consistent (these modules are in the second -- argument). -tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo] -tcGetModuleExports mod directlyImpMods +tcGetModuleExports :: Module -> TcM [AvailInfo] +tcGetModuleExports mod = do { let doc = ptext (sLit "context for compiling statements") ; iface <- initIfaceTcRn $ loadSysInterface doc mod -- Load any orphan-module and family instance-module -- interfaces, so their instances are visible. ; loadOrphanModules (dep_orphs (mi_deps iface)) False - ; loadOrphanModules (dep_finsts (mi_deps iface)) True - - -- Check that the family instances of all directly loaded - -- modules are consistent. - ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods ; ifaceExportNames (mi_exports iface) } -tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ lookup_rdr_name rdr_name +lookup_rdr_name :: RdrName -> TcM [Name] lookup_rdr_name rdr_name = do { -- If the identifier is a constructor (begins with an -- upper-case letter), then we need to consider both @@ -1336,8 +1419,9 @@ lookup_rdr_name rdr_name = do { return good_names } +#endif -tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ @@ -1356,10 +1440,10 @@ tcRnLookupName' name = do _ -> panic "tcRnLookupName'" tcRnGetInfo :: HscEnv - -> Name - -> IO (Maybe (TyThing, Fixity, [Instance])) + -> Name + -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) --- Used to implemnent :info in GHCi +-- Used to implement :info in GHCi -- -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, @@ -1367,8 +1451,14 @@ tcRnGetInfo :: HscEnv -- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env name - = initTcPrintErrors hsc_env iNTERACTIVE $ - let ictxt = hsc_IC hsc_env in + = initTcPrintErrors hsc_env iNTERACTIVE $ + tcRnGetInfo' hsc_env name + +tcRnGetInfo' :: HscEnv + -> Name + -> TcRn (TyThing, Fixity, [Instance]) +tcRnGetInfo' hsc_env name + = let ictxt = hsc_IC hsc_env in setInteractiveContext hsc_env ictxt $ do -- Load the interface for all unqualified types and classes @@ -1388,19 +1478,19 @@ lookupInsts (AClass cls) ; return (classInstances inst_envs cls) } lookupInsts (ATyCon tc) - = do { eps <- getEps -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all - ; return [ ispec + = do { (pkg_ie, home_ie) <- tcGetInstEnvs + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + ; return [ ispec -- Search all | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie , let dfun = instanceDFunId ispec , relevant dfun ] } where - relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) + relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df) tc_name = tyConName tc -lookupInsts other = return [] +lookupInsts _ = return [] loadUnqualIfaces :: InteractiveContext -> TcM () -- Load the home module for everything that is in scope unqualified @@ -1417,7 +1507,6 @@ loadUnqualIfaces ictxt isTcOcc (nameOccName name), -- Types and classes only unQualOK gre ] -- In scope unqualified doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") -#endif /* GHCI */ \end{code} %************************************************************************ @@ -1448,6 +1537,7 @@ tcDump env -- NB: foreign x-d's have undefined's in their types; -- hence can't show the tc_fords +tcCoreDump :: ModGuts -> TcM () tcCoreDump mod_guts = do { dflags <- getDOpts ; when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) @@ -1461,18 +1551,19 @@ tcCoreDump mod_guts -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_vects = vects, + tcg_imports = imports }) = vcat [ ppr_types insts type_env , ppr_tycons fam_insts type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , vcat (map ppr rules) - , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext (sLit "Dependent modules:") <+> - ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ppr_insts insts + , ppr_fam_insts fam_insts + , vcat (map ppr rules) + , vcat (map ppr vects) + , ptext (sLit "Dependent modules:") <+> + ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent packages:") <+> ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary @@ -1505,7 +1596,10 @@ ppr_types insts type_env ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env - = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons) + = vcat [ text "TYPE CONSTRUCTORS" + , nest 2 (ppr_tydecls tycons) + , text "COERCION AXIOMS" + , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] where fi_tycons = map famInstTyCon fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] @@ -1537,17 +1631,11 @@ ppr_tydecls tycons = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 - ppr_tycon tycon - | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon - | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) + ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon)) ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), - nest 4 (pprRules rs), + nest 2 (pprRules rs), ptext (sLit "#-}")] - -ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"), - nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code}