X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=c4b351724f36524ffd5ed5a62a00b1bdb81c27dc;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hp=f8c6c4c4d38e3a72d3c3ddd2b297940f62a7cc07;hpb=85f969a6585c06168645114d9524e7169dbc6e32;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index f8c6c4c..c4b3517 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,20 +5,14 @@ \section[TcModule]{Typechecking a whole module} \begin{code} --- 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, - tcRnLookupName, - tcRnGetInfo, getModuleExports, #endif + tcRnLookupName, + tcRnGetInfo, tcRnModule, tcTopSrcDecls, tcRnExtCore @@ -31,7 +25,6 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags import StaticFlags import HsSyn -import RdrHsSyn import PrelNames import RdrName import TcHsSyn @@ -66,7 +59,7 @@ import Id import VarEnv import Var import Module -import LazyUniqFM +import UniqFM import Name import NameEnv import NameSet @@ -79,6 +72,7 @@ import Outputable import DataCon import Type import Class +import TcType import Data.List ( sortBy ) #ifdef GHCI @@ -91,7 +85,6 @@ import IfaceEnv import MkId import BasicTypes import TidyPgm ( globaliseAndTidyId ) -import TcType ( isUnitTy, isTauTy, tyClsNamesOfDFunHead ) import TysWiredIn ( unitTy, mkListTy ) #endif @@ -304,7 +297,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- any mutually recursive types are done right -- 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 ; + (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@ -417,7 +410,7 @@ 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 @@ -440,7 +433,7 @@ tc_rn_src_decls boot_details ds 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 { + 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) ; @@ -467,7 +460,7 @@ tc_rn_src_decls boot_details ds \begin{code} tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls - = do { let { (first_group, group_tail) = findSplice decls } + = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations ; (tcg_env, HsGroup { @@ -484,16 +477,18 @@ tcRnHsBootDecls decls -- Check for illegal declarations ; case group_tail of - Just (SpliceDecl d, _) -> badBootDecl "splice" d - Nothing -> return () + Just (SpliceDecl d _, _) -> badBootDecl "splice" d + Nothing -> return () ; mapM_ (badBootDecl "foreign") for_decls ; mapM_ (badBootDecl "default") def_decls ; mapM_ (badBootDecl "rule") rule_decls -- Typecheck type/class decls ; traceTc (text "Tc2") - ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { + ; (tcg_env, aux_binds, dm_ids) + <- tcTyAndClassDecls emptyModDetails tycl_decls + ; setGblEnv tcg_env $ + tcExtendIdEnv dm_ids $ do { -- Typecheck instance decls -- Family instance declarations are rejected here @@ -573,15 +568,19 @@ checkHiBootIface -- 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 [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] + ; 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 () @@ -824,10 +823,12 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc (text "Tc2") ; - (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - setGblEnv tcg_env $ do { + setGblEnv tcg_env $ + tcExtendIdEnv dm_ids $ do { + -- Source-language instances, including derivings, -- and import the supporting declarations traceTc (text "Tc3") ; @@ -857,13 +858,12 @@ tcTopSrcDecls boot_details (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcTopBinds val_binds; + setLclTypeEnv tcl_env $ do { -- Environment doesn't change now + -- 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") ; - - setLclTypeEnv tcl_env $ do { -- Environment doesn't change now + inst_binds <- tcInstDecls2 tycl_decls inst_infos ; + showLIE (text "after instDecls2") ; -- Foreign exports traceTc (text "Tc7") ; @@ -1018,7 +1018,6 @@ 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. @@ -1049,6 +1048,7 @@ setInteractiveContext hsc_env icxt thing_inside \begin{code} +#ifdef GHCI tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName @@ -1205,7 +1205,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt ]} 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 @@ -1236,7 +1236,7 @@ tcGhciStmts stmts io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ; - names = map unLoc (collectLStmtsBinders stmts) ; + names = collectLStmtsBinders stmts ; -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] @@ -1344,7 +1344,7 @@ 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 + checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic) in initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) @@ -1404,6 +1404,7 @@ lookup_rdr_name rdr_name = do { return good_names } +#endif tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name @@ -1424,8 +1425,8 @@ tcRnLookupName' name = do _ -> panic "tcRnLookupName'" tcRnGetInfo :: HscEnv - -> Name - -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) + -> Name + -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) -- Used to implement :info in GHCi -- @@ -1435,8 +1436,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 @@ -1485,7 +1492,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} %************************************************************************