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
import TcExpr
import TcRnMonad
import TcType
+import Coercion
import Inst
import FamInst
import InstEnv
import NameEnv
import NameSet
import TyCon
+import TysPrim
import TysWiredIn
import SrcLoc
import HscTypes
#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) ;
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 ;
-- 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,
-- 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 [ mkVarBind 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 " ++
final_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)
+ dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
| (boot_dfun, dfun) <- dfun_prs ]
; failIfErrsM
(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")
(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
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 | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn)
- | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn)
+ pp_main_fn = ppMainFn main_fn
+
+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]
-> 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,
where
le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
ppr_tycon tycon
- | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon
+ | isCoercionTyCon tycon
+ = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
+ , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
| otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon))
+ where
+ tvs = take (tyConArity tycon) alphaTyVars
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
projects / ghc-hetmet.git / blobdiff