tcRnExtCore
) where
-import IO
+import System.IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
import StaticFlags
import HsSyn
import RdrHsSyn
-
import PrelNames
import RdrName
import TcHsSyn
#include "HsVersions.h"
\end{code}
-
-
%************************************************************************
%* *
Typecheck and rename a module
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) ;
-- 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 ;
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,
(idType id1 `tcEqType` 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 &&
+ 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)
+
+ 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 (tcEqPredX env) sc_theta1 sc_theta2 &&
+ eqListBy eqSig op_stuff1 op_stuff2 &&
+ eqListBy checkBootTyCon ats1 ats2)
+
+checkBootDecl (ADataCon dc1) (ADataCon dc2)
+ = 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
| isAlgTyCon tc1 && isAlgTyCon tc2
= ASSERT(tc1 == tc2)
- eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2)
- && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
+ eqKind (tyConKind tc1) (tyConKind tc2) &&
+ eqListBy tcEqPred (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
where
env0 = mkRnEnv2 emptyInScopeSet
(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
-
----------------
missingBootThing thing what
= ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not")
pp_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
\end{code}
Note [Root-main Id]