The immediate reason for this patch is to fix #3823. This was
rather easy: all the work was being done but I was returning
type_env2 rather than type_env3.
An unused-veriable warning would have shown this up, so I fixed all
the other warnings in TcRnDriver. Doing so showed up at least two
genuine lurking bugs. Hurrah.
\section[TcModule]{Typechecking a whole module}
\begin{code}
\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
-- 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
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
import TcHsSyn
import TcExpr
import TcRnMonad
import TcHsSyn
import TcExpr
import TcRnMonad
import Coercion
import Inst
import FamInst
import Coercion
import Inst
import FamInst
import RnNames
import RnEnv
import RnSource
import RnNames
import RnEnv
import RnSource
import PprCore
import CoreSyn
import ErrUtils
import PprCore
import CoreSyn
import ErrUtils
import NameSet
import TyCon
import TysPrim
import NameSet
import TyCon
import TysPrim
import SrcLoc
import HscTypes
import ListSetOps
import SrcLoc
import HscTypes
import ListSetOps
import Data.List ( sortBy )
#ifdef GHCI
import Data.List ( sortBy )
#ifdef GHCI
import TcHsType
import TcMType
import TcMatches
import TcHsType
import TcMType
import TcMatches
import RnExpr
import IfaceEnv
import MkId
import RnExpr
import IfaceEnv
import MkId
-import IdInfo
-import {- Kind parts of -} Type
-import Foreign.Ptr( Ptr )
-import TidyPgm ( globaliseAndTidyId )
+import TidyPgm ( globaliseAndTidyId )
+import TcType ( isUnitTy, isTauTy, tyClsNamesOfDFunHead )
+import TysWiredIn ( unitTy, mkListTy )
import Bag
import Control.Monad
import Bag
import Control.Monad
-import Data.Maybe ( isJust )
#include "HsVersions.h"
\end{code}
#include "HsVersions.h"
\end{code}
mg_inst_env = tcg_inst_env tcg_env,
mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_rules = [],
mg_inst_env = tcg_inst_env tcg_env,
mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_rules = [],
mg_binds = core_binds,
-- Stubs
mg_binds = core_binds,
-- Stubs
+mkFakeGroup :: [LTyClDecl a] -> HsGroup a
mkFakeGroup decls -- Rather clumsy; lots of unused fields
= emptyRdrGroup { hs_tyclds = decls }
\end{code}
mkFakeGroup decls -- Rather clumsy; lots of unused fields
= emptyRdrGroup { hs_tyclds = decls }
\end{code}
return (tcg_env, tcl_env)
} ;
return (tcg_env, tcl_env)
} ;
- -- If there's a splice, we must carry on
- Just (SpliceDecl splice_expr, rest_ds) -> do {
+ -- There shouldn't be a splice
+ Just (SpliceDecl {}, _) -> do {
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
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) ;
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
tcRnHsBootDecls decls
= do { let { (first_group, group_tail) = findSplice decls }
tcRnHsBootDecls decls
= do { let { (first_group, group_tail) = findSplice decls }
- ; case group_tail of
- Just stuff -> spliceInHsBootErr stuff
- Nothing -> return ()
-
-- Rename the declarations
; (tcg_env, HsGroup {
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
-- Rename the declarations
; (tcg_env, HsGroup {
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
- hs_fords = _,
- hs_defds = _, -- Todo: check no foreign decls, no rules,
- hs_ruleds = _, -- no default decls and no annotation decls
+ hs_fords = for_decls,
+ hs_defds = def_decls,
+ hs_ruleds = rule_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
; setGblEnv tcg_env $ do {
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
; setGblEnv tcg_env $ do {
+ -- 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
+
-- Typecheck type/class decls
; traceTc (text "Tc2")
; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
-- Typecheck type/class decls
; traceTc (text "Tc2")
; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
+ -- Family instance declarations are rejected here
; traceTc (text "Tc3")
; (tcg_env, inst_infos, _deriv_binds)
<- tcInstDecls1 tycl_decls inst_decls deriv_decls
; traceTc (text "Tc3")
; (tcg_env, inst_infos, _deriv_binds)
<- tcInstDecls1 tycl_decls inst_decls deriv_decls
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
- ; type_env3 = extendTypeEnvWithIds type_env1 aux_ids
+ ; 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"
}
; 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_env2
+ ; setGlobalTypeEnv gbl_env type_env3
-spliceInHsBootErr (SpliceDecl (L loc _), _)
- = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files"))
+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
\end{code}
Once we've typechecked the body of the module, we want to compare what
checkHiBootIface
tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
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 })
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 })
-- Check the exports of the boot module, one by one
; mapM_ check_export 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 [ 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 " ++
-- Check for no family instances
; unless (null boot_fam_insts) $
panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
-- Check instance declarations
; mb_dfun_prs <- mapM check_inst boot_insts
-- Check instance declarations
; mb_dfun_prs <- mapM check_inst boot_insts
- ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
- final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
+ ; 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 ]
; failIfErrsM
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 ]
; failIfErrsM
- ; setGlobalTypeEnv tcg_env' final_type_env }
where
check_export boot_avail -- boot_avail is exported by the boot iface
| name `elem` dfun_names = return ()
where
check_export boot_avail -- boot_avail is exported by the boot iface
| name `elem` dfun_names = return ()
eqSig (id1, def_meth1) (id2, def_meth2)
= idName id1 == idName id2 &&
eqSig (id1, def_meth1) (id2, def_meth2)
= idName id1 == idName id2 &&
- tcEqTypeX env op_ty1 op_ty2
+ tcEqTypeX env op_ty1 op_ty2 &&
+ def_meth1 == def_meth2
where
(_, rho_ty1) = splitForAllTys (idType id1)
op_ty1 = funResultTy rho_ty1
where
(_, rho_ty1) = splitForAllTys (idType id1)
op_ty1 = funResultTy rho_ty1
eqListBy eqSig op_stuff1 op_stuff2 &&
eqListBy checkBootTyCon ats1 ats2)
eqListBy eqSig op_stuff1 op_stuff2 &&
eqListBy checkBootTyCon ats1 ats2)
-checkBootDecl (ADataCon dc1) (ADataCon dc2)
+checkBootDecl (ADataCon dc1) (ADataCon _)
= pprPanic "checkBootDecl" (ppr dc1)
checkBootDecl _ _ = False -- probably shouldn't happen
= pprPanic "checkBootDecl" (ppr dc1)
checkBootDecl _ _ = False -- probably shouldn't happen
= tcEqTypeX env k1 k2
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
= tcEqTypeX env t1 t2
= tcEqTypeX env k1 k2
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
= tcEqTypeX env t1 t2
in
equalLength tvs1 tvs2 &&
eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
in
equalLength tvs1 tvs2 &&
eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
| isForeignTyCon tc1 && isForeignTyCon tc2
= eqKind (tyConKind tc1) (tyConKind tc2) &&
tyConExtName tc1 == tyConExtName tc2
| isForeignTyCon tc1 && isForeignTyCon tc2
= eqKind (tyConKind tc1) (tyConKind tc2) &&
tyConExtName tc1 == tyConExtName tc2
where
env0 = mkRnEnv2 emptyInScopeSet
where
env0 = mkRnEnv2 emptyInScopeSet
(dataConOrigArgTys c2)
----------------
(dataConOrigArgTys 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")
<+> 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]
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"))
instMisMatch inst
= hang (ppr inst)
2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
check_main dflags tcg_env
}
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) >>
check_main dflags tcg_env
| mod /= main_mod
= traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
<+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
pp_main_fn = ppMainFn main_fn
<+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
pp_main_fn = ppMainFn main_fn
+ppMainFn :: RdrName -> SDoc
ppMainFn main_fn
| main_fn == main_RDR_Unqual
= ptext (sLit "function") <+> quotes (ppr main_fn)
ppMainFn main_fn
| main_fn == main_RDR_Unqual
= ptext (sLit "function") <+> quotes (ppr main_fn)
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.
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,
in
updGblEnv (\env -> env {
tcg_rdr_env = ic_rn_gbl_env icxt,
-- None of the Ids should be of unboxed type, because we
-- cast them all to HValues in the end!
-- 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 (text "tcs 1") ;
let { global_ids = map globaliseAndTidyId zonked_ids } ;
traceTc (text "tcs 1") ;
let { global_ids = map globaliseAndTidyId zonked_ids } ;
-- 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
-- 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] }
]}
--- checkNoErrs defeats the error recovery of let-bindings
; tcGhciStmts [let_stmt, print_it] }
]}
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
= 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)
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) ;
+ ((_tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
- tcSimplifyInteractive lie_top ;
+ _ <- tcSimplifyInteractive lie_top ; -- Ignore the dicionary bindings
let { all_expr_ty = mkForAllTys qtvs $
mkFunTys (map (idType . instToId) dict_insts) $
let { all_expr_ty = mkForAllTys qtvs $
mkFunTys (map (idType . instToId) dict_insts) $
failIfErrsM ;
-- Now kind-check the type
failIfErrsM ;
-- Now kind-check the type
- (ty', kind) <- kcLHsType rn_type ;
+ (_ty', kind) <- kcLHsType rn_type ;
setInteractiveContext hsc_env (hsc_IC hsc_env) $
lookup_rdr_name rdr_name
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
lookup_rdr_name rdr_name = do {
-- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
; return (classInstances inst_envs cls) }
lookupInsts (ATyCon tc)
; 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 ] }
| ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
, let dfun = instanceDFunId ispec
, relevant dfun ] }
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
tc_name = tyConName tc
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (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
loadUnqualIfaces :: InteractiveContext -> TcM ()
-- Load the home module for everything that is in scope unqualified
-- NB: foreign x-d's have undefined's in their types;
-- hence can't show the tc_fords
-- 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)
tcCoreDump mod_guts
= do { dflags <- getDOpts ;
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
nest 4 (pprRules rs),
ptext (sLit "#-}")]
nest 4 (pprRules rs),
ptext (sLit "#-}")]
+ppr_gen_tycons :: [TyCon] -> SDoc
ppr_gen_tycons [] = empty
ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
ppr_gen_tycons [] = empty
ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
= -- Prime error recovery, set source location
setSrcSpan loc $
tcAddDeclCtxt decl $
= -- Prime error recovery, set source location
setSrcSpan loc $
tcAddDeclCtxt decl $
- do { -- type families require -XTypeFamilies and can't be in an
- -- hs-boot file
+ do { -- type family instances require -XTypeFamilies
+ -- and can't (currently) be in an hs-boot file
; type_families <- doptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)
; type_families <- doptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)