% (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}
module TcRnDriver (
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
- getModuleExports,
+ getModuleExports,
#endif
+ tcRnImports,
tcRnLookupName,
tcRnGetInfo,
tcRnModule,
import NameEnv
import NameSet
import TyCon
-import TysPrim
import SrcLoc
import HscTypes
import ListSetOps
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,
-- It's a waste of time; and we may get debug warnings
-- about strangely-typed TyCons!
- -- Zonk the final code. This must be done last.
- -- Even simplifyTop may do some unification.
+ -- 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_fords = fords } = tcg_env
+ 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')
- <- zonkTopDecls all_ev_binds binds sig_ns rules 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_fords = fords' } } ;
-
- setGlobalTypeEnv tcg_env' final_type_env
+ (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)
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 {
; 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 "Tc2" empty
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
- idType dfun `tcEqType` boot_inst_ty ] of
+ 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
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
eqSig (id1, def_meth1) (id2, def_meth2)
= idName id1 == idName id2 &&
- tcEqTypeX env op_ty1 op_ty2 &&
+ eqTypeX env op_ty1 op_ty2 &&
def_meth1 == def_meth2
where
(_, rho_ty1) = splitForAllTys (idType id1)
op_ty2 = funResultTy rho_ty2
eqFD (as1,bs1) (as2,bs2) =
- eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
- eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys 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 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 (eqPredX env) sc_theta1 sc_theta2 &&
eqListBy eqSig op_stuff1 op_stuff2 &&
eqListBy checkBootTyCon ats1 ats2)
eqSynRhs SynFamilyTyCon SynFamilyTyCon
= True
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
- = tcEqTypeX env t1 t2
+ = eqTypeX env t1 t2
eqSynRhs _ _ = False
in
equalLength tvs1 tvs2 &&
| isAlgTyCon tc1 && isAlgTyCon tc2
= ASSERT(tc1 == tc2)
eqKind (tyConKind tc1) (tyConKind tc2) &&
- eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
+ eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
| isForeignTyCon tc1 && isForeignTyCon 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)
+ && eqType (dataConUserType c1) (dataConUserType c2)
----------------
missingBootThing :: Name -> String -> SDoc
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
setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
- -- Second pass over class and instance declarations,
+ -- Second pass over class and instance declarations,
traceTc "Tc6" empty ;
- inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
+ inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
- -- Foreign exports
+ -- Foreign exports
traceTc "Tc7" empty ;
- (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
-- Annotations
- annotations <- tcAnnotations annotation_decls ;
+ annotations <- tcAnnotations annotation_decls ;
- -- Rules
- rules <- tcRules rule_decls ;
+ -- Rules
+ rules <- tcRules rule_decls ;
- -- Wrap up
+ -- Vectorisation declarations
+ vects <- tcVectDecls vect_decls ;
+
+ -- Wrap up
traceTc "Tc7a" empty ;
tcg_env <- getGblEnv ;
let { all_binds = tc_val_binds `unionBags`
; 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
+ -- 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_anns = tcg_anns tcg_env ++ annotations
- , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
- return (tcg_env', tcl_env)
+ , 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}
--------------------
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
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::()
mkPlan stmt@(L loc (BindStmt {}))
| [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
let {
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
- tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ;
-
+ tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ;
names = 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
- -- mk_return builds the expression
+ -- Simplify the context
+ traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+ const_binds <- checkNoErrs (simplifyInteractive lie) ;
+ -- checkNoErrs ensures that the plan fails if context redn fails
+
+ 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,
-- 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 "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
-
- traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ (nlHsVar id) ;
+ stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
+ } ;
return (ids, mkHsDictLet (EvBinds const_binds) $
- noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
+ noLoc (HsDo GhciStmt stmts io_ret_ty))
}
\end{code}
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
-
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 -}
+ ((_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) } ;
-- 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)
+ , ppr_gen_tycons (typeEnvTyCons type_env)
+ , 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
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]
= vcat (map ppr_tycon (sortLe le_sig tycons))
where
le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
- ppr_tycon 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))
+ ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon))
where
- tvs = take (tyConArity tycon) alphaTyVars
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
projects / ghc-hetmet.git / blobdiff