X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=4a1203a8363f93ffa0c36197f38d0d9774f68369;hb=2767767f7b4acf89f56d18231f143b60429631f6;hp=282e61b548659ab4108c03bd2acb5ac0a44a56fd;hpb=51a571c0f5b0201ea53bec60fcaafb78c01c017e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 282e61b..4a1203a 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -27,16 +27,20 @@ import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..), import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, newLocalId ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyToDicts ) -import TcMonoType ( tcHsSigType, checkSigTyVars, +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts ) +import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars, TcSigInfo(..), tcTySig, maybeSig, sigCtxt ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( newTyVarTy, newTyVar, - zonkTcTyVarToTyVar +import TcMType ( newTyVarTy, newTyVar, + zonkTcTyVarToTyVar, + unifyTauTy, unifyTauTyLists + ) +import TcType ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, + mkPredTy, mkForAllTy, isUnLiftedType, + unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind ) -import TcUnify ( unifyTauTy, unifyTauTyLists ) import CoreFVs ( idFreeTyVars ) import Id ( mkLocalId, setInlinePragma ) @@ -44,16 +48,10 @@ import Var ( idType, idName ) import IdInfo ( InlinePragInfo(..) ) import Name ( Name, getOccName, getSrcLoc ) import NameSet -import Type ( mkTyVarTy, tyVarsOfTypes, - mkForAllTys, mkFunTys, tyVarsOfType, - mkPredTy, mkForAllTy, isUnLiftedType, - unliftedTypeKind, liftedTypeKind, openTypeKind - ) import Var ( tyVarKind ) import VarSet import Bag import Util ( isIn ) -import ListSetOps ( minusList ) import Maybes ( maybeToBool ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel ) import FiniteMap ( listToFM, lookupFM ) @@ -225,10 +223,12 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- TYPECHECK THE BINDINGS tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) -> let - tau_tvs = varSetElems (foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids) + tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids in -- GENERALISE + tcAddSrcLoc (minimum (map getSrcLoc binder_names)) $ + tcAddErrCtxt (genCtxt binder_names) $ generalise binder_names mbind tau_tvs lie_req tc_ty_sigs `thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) -> @@ -289,10 +289,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- at all. in + traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds), + exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_` + -- BUILD RESULTS returnTc ( - -- pprTrace "binding.." (ppr ((zonked_dict_ids, dict_binds), - -- exports, [idType poly_id | (_, poly_id, _) <- exports])) $ AbsBinds real_tyvars_to_gen zonked_dict_ids exports @@ -308,7 +309,7 @@ attachNoInlinePrag no_inlines bndr Nothing -> bndr checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids - = ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) ) + = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) ) -- The instCantBeGeneralised stuff in tcSimplify should have -- already raised an error if we're trying to generalise an -- unboxed tyvar (NB: unboxed tyvars are always introduced @@ -410,20 +411,29 @@ is doing. %************************************************************************ \begin{code} -generalise_help doc tau_tvs lie_req sigs +generalise binder_names mbind tau_tvs lie_req sigs + | not is_unrestricted -- RESTRICTED CASE + = -- Check signature contexts are empty + checkTc (all is_mono_sig sigs) + (restrictedBindCtxtErr binder_names) `thenTc_` ------------------------ - | null sigs - = -- INFERENCE CASE: Unrestricted group, no type signatures - tcSimplifyInfer doc - tau_tvs lie_req + -- Now simplify with exactly that set of tyvars + -- We have to squash those Methods + tcSimplifyRestricted doc tau_tvs lie_req `thenTc` \ (qtvs, lie_free, binds) -> ------------------------ - | otherwise + -- Check that signature type variables are OK + checkSigsTyVars sigs `thenTc_` + + returnTc (qtvs, lie_free, binds, []) + + | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS + = tcSimplifyInfer doc tau_tvs lie_req + + | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS = -- CHECKING CASE: Unrestricted group, there are type signatures -- Check signature contexts are empty checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) -> - + -- Check that the needed dicts can be -- expressed in terms of the signature ones tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) -> @@ -433,47 +443,14 @@ generalise_help doc tau_tvs lie_req sigs returnTc (forall_tvs, lie_free, dict_binds, sig_dicts) -generalise binder_names mbind tau_tvs lie_req sigs - | is_unrestricted -- UNRESTRICTED CASE - = generalise_help doc tau_tvs lie_req sigs - - | otherwise -- RESTRICTED CASE - = -- Do a simplification to decide what type variables - -- are constrained. We can't just take the free vars - -- of lie_req because that'll have methods that may - -- incidentally mention entirely unconstrained variables - -- e.g. a call to f :: Eq a => a -> b -> b - -- Here, b is unconstrained. A good example would be - -- foo = f (3::Int) - -- We want to infer the polymorphic type - -- foo :: forall b. b -> b - generalise_help doc tau_tvs lie_req sigs `thenTc` \ (forall_tvs, lie_free, dict_binds, dict_ids) -> - - -- Check signature contexts are empty - checkTc (null sigs || null dict_ids) - (restrictedBindCtxtErr binder_names) `thenTc_` - - -- Identify constrained tyvars - let - constrained_tvs = varSetElems (tyVarsOfTypes (map idType dict_ids)) - -- The dict_ids are fully zonked - final_forall_tvs = forall_tvs `minusList` constrained_tvs - in - - -- Now simplify with exactly that set of tyvars - -- We have to squash those Methods - tcSimplifyCheck doc final_forall_tvs [] lie_req `thenTc` \ (lie_free, binds) -> - - returnTc (final_forall_tvs, lie_free, binds, []) - where is_unrestricted | opt_NoMonomorphismRestriction = True | otherwise = isUnRestrictedGroup tysig_names mbind tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs] + is_mono_sig (TySigInfo _ _ _ theta _ _ _ _) = null theta - doc | null sigs = ptext SLIT("banding(s) for") <+> pprBinders binder_names - | otherwise = ptext SLIT("type signature(s) for") <+> pprBinders binder_names + doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names ----------------------- -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE @@ -483,8 +460,9 @@ generalise binder_names mbind tau_tvs lie_req sigs -- We unify them because, with polymorphic recursion, their types -- might not otherwise be related. This is a rather subtle issue. -- ToDo: amplify -checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs) - = mapTc_ check_one other_sigs `thenTc_` +checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs) + = tcAddSrcLoc src_loc $ + mapTc_ check_one other_sigs `thenTc_` if null theta1 then returnTc ([], []) -- Non-overloaded type signatures else @@ -502,8 +480,7 @@ checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs) sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs] check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (sigContextsCtxt id1 id) $ + = tcAddErrCtxt (sigContextsCtxt id1 id) $ checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_` unifyTauTyLists sig1_dict_tys (map mkPredTy theta) @@ -697,7 +674,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec complete_it xve = tcAddSrcLoc locn $ tcAddErrCtxt (patMonoBindsCtxt bind) $ tcExtendLocalValEnv xve $ - tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) -> + tcGRHSs PatBindRhs grhss pat_ty `thenTc` \ (grhss', lie) -> returnTc (PatMonoBind pat' grhss' locn, lie) in returnTc (complete_it, lie_req, tvs, ids, lie_avail) @@ -759,7 +736,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) tcAddErrCtxt (valSpecSigCtxt name poly_ty) $ -- Get and instantiate its alleged specialised type - tcHsSigType poly_ty `thenTc` \ sig_ty -> + tcHsSigType (FunSigCtxt name) poly_ty `thenTc` \ sig_ty -> -- Check that f has a more general type, and build a RHS for -- the spec-pragma-id at the same time @@ -825,6 +802,9 @@ restrictedBindCtxtErr binder_names 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names, ptext SLIT("that falls under the monomorphism restriction")]) +genCtxt binder_names + = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names + -- Used in error messages -pprBinders bndrs = braces (pprWithCommas ppr bndrs) +pprBinders bndrs = pprWithCommas ppr bndrs \end{code}