X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FGenSpecEtc.lhs;h=e3d626712109e198eea2cc4562434e2aec019702;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=087206a612f4908c9b15d31d40ae0975e351d34e;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index 087206a..e3d6267 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -9,37 +9,43 @@ module GenSpecEtc ( TcSigInfo(..), genBinds, - checkSigTyVars, checkSigTyVarsGivenGlobals + checkSigTyVars ) where -import Ubiq +IMP_Ubiq() -import TcMonad -import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE, +import TcMonad hiding ( rnMtoTcM ) +import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE, newDicts, tyVarsOfInst, instToId ) -import TcEnv ( tcGetGlobalTyVars ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals ) -import TcType ( TcType(..), TcThetaType(..), TcTauType(..), - TcTyVarSet(..), TcTyVar(..), tcInstType, zonkTcType ) +import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars ) +import SpecEnv ( SpecEnv ) +import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) +import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType), + SYN_IE(TcTyVarSet), SYN_IE(TcTyVar), + newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars + ) +import Unify ( unifyTauTy ) import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..), Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake ) -import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..), tcIdType ) +import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcExpr), tcIdType ) import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag ) import Class ( GenClass ) -import Id ( GenId, Id(..), mkUserId, idType ) +import Id ( GenId, SYN_IE(Id), mkUserId, idType ) +import Kind ( isUnboxedKind, isTypeKind, mkBoxedTypeKind ) import ListSetOps ( minusList, unionLists, intersectLists ) -import Maybes ( Maybe(..), allMaybes ) +import Maybes ( allMaybes ) +import Name ( Name{--O only-} ) import Outputable ( interppSP, interpp'SP ) import Pretty import PprType ( GenClass, GenType, GenTyVar ) import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys, - getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta ) -import TyVar ( GenTyVar, TyVar(..), minusTyVarSet, emptyTyVarSet, + getTyVar, getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta ) +import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet, elementOfTyVarSet, unionTyVarSets, tyVarSetToList ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Unique ( Unique ) import Util \end{code} @@ -145,25 +151,45 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn let mentioned_tyvars = tyVarsOfTypes mono_id_types tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars + tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- sig_infos] in -- DEAL WITH OVERLOADING - resolveOverloading tyvars_to_gen lie bind sig_infos + resolveOverloading tyvars_to_gen lie bind tysig_vars (head thetas) `thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) -> + -- Check for generaliseation over unboxed types, and + -- default any TypeKind TyVars to BoxedTypeKind + let + tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order + + unboxed_kind_tyvars = filter (isUnboxedKind . tyVarKind) tyvars + unresolved_kind_tyvars = filter (isTypeKind . tyVarKind) tyvars + + box_it tyvar = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ boxed_ty -> + unifyTauTy boxed_ty (mkTyVarTy tyvar) + + in + ASSERT( null unboxed_kind_tyvars ) -- The instCantBeGeneralised stuff in tcSimplify + -- should have dealt with unboxed type variables; + -- and it's better done there because we have more + -- precise origin information + + -- Default any TypeKind variables to BoxedTypeKind + mapTc box_it unresolved_kind_tyvars `thenTc_` + -- BUILD THE NEW LOCALS let - tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order dict_tys = map tcIdType dicts_bound poly_tys = map (mkForAllTys tyvars . mkFunTys dict_tys) mono_id_types - poly_ids = zipWithEqual mk_poly binder_names poly_tys + poly_ids = zipWithEqual "genspecetc" mk_poly binder_names poly_tys mk_poly name ty = mkUserId name ty (prag_info_fn name) in -- BUILD RESULTS returnTc ( AbsBinds tyvars dicts_bound - (map TcId mono_ids `zip` map TcId poly_ids) + (zipEqual "genBinds" (map TcId mono_ids) (map TcId poly_ids)) dict_binds bind, lie', @@ -180,14 +206,16 @@ resolveOverloading :: TcTyVarSet s -- Tyvars over which we are going to generalise -> LIE s -- The LIE to deal with -> TcBind s -- The binding group - -> [TcSigInfo s] -- And its real type-signature information + -> [TcIdBndr s] -- Variables in type signatures + -> TcThetaType s -- *Zonked* theta for the overloading in type signature + -- (if there are any type signatures; error otherwise) -> TcM s (LIE s, -- LIE to pass up the way; a fixed point of -- the current substitution TcTyVarSet s, -- Revised tyvars to generalise [(TcIdOcc s, TcExpr s)], -- Dict bindings [TcIdOcc s]) -- List of dicts to bind here -resolveOverloading tyvars_to_gen dicts bind ty_sigs +resolveOverloading tyvars_to_gen dicts bind tysig_vars theta | not (isUnRestrictedGroup tysig_vars bind) = -- Restricted group, so bind no dictionaries, and -- remove from tyvars_to_gen any constrained type variables @@ -233,7 +261,9 @@ resolveOverloading tyvars_to_gen dicts bind ty_sigs -- may gratuitouslyconstrain some tyvars over which we *are* going -- to generalise. -- For example d::Eq (Foo a b), where Foo is instanced as above. - tcSimplifyWithExtraGlobals constrained_tyvars reduced_tyvars_to_gen dicts + tcExtendGlobalTyVars constrained_tyvars ( + tcSimplify reduced_tyvars_to_gen dicts + ) `thenTc` \ (dicts_free, dicts_binds, dicts_sig2) -> ASSERT(isEmptyBag dicts_sig2) @@ -244,32 +274,29 @@ resolveOverloading tyvars_to_gen dicts bind ty_sigs -- The returned LIE should be a fixed point of the substitution - | otherwise -- An unrestricted group - = case ty_sigs of - [] -> -- NO TYPE SIGNATURES - - tcSimplify tyvars_to_gen dicts `thenTc` \ (dicts_free, dict_binds, dicts_sig) -> - returnTc (dicts_free, tyvars_to_gen, dict_binds, - map instToId (bagToList dicts_sig)) - - (TySigInfo _ _ theta _ _ : other) -> -- TYPE SIGNATURES PRESENT! - - tcAddErrCtxt (sigsCtxt tysig_vars) $ - - newDicts SignatureOrigin theta `thenNF_Tc` \ (dicts_sig, dict_ids) -> - - -- Check that the needed dicts can be expressed in - -- terms of the signature ones - tcSimplifyAndCheck + | null tysig_vars -- An unrestricted group with no type signaturs + = tcSimplify tyvars_to_gen dicts `thenTc` \ (dicts_free, dict_binds, dicts_sig) -> + returnTc (dicts_free, tyvars_to_gen, dict_binds, + map instToId (bagToList dicts_sig)) + + | otherwise -- An unrestricted group with type signatures + = tcAddErrCtxt (sigsCtxt tysig_vars) $ + newDicts SignatureOrigin theta `thenNF_Tc` \ (dicts_sig, dict_ids) -> + -- It's important that theta is pre-zonked, because + -- dict_id is later used to form the type of the polymorphic thing, + -- and forall-types must be zonked so far as their bound variables + -- are concerned + + -- Check that the needed dicts can be expressed in + -- terms of the signature ones + tcSimplifyAndCheck tyvars_to_gen -- Type vars over which we will quantify dicts_sig -- Available dicts dicts -- Want bindings for these dicts `thenTc` \ (dicts_free, dict_binds) -> - returnTc (dicts_free, tyvars_to_gen, dict_binds, dict_ids) - where - tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs] + returnTc (dicts_free, tyvars_to_gen, dict_binds, dict_ids) \end{code} @checkSigMatch@ does the next step in checking signature matching. @@ -355,24 +382,28 @@ checkSigTyVars :: [TcTyVar s] -- The original signature type variables -> TcM s () checkSigTyVars sig_tyvars sig_tau - = tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars -> - checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau - -checkSigTyVarsGivenGlobals - :: TcTyVarSet s -- Consider these fully-zonked tyvars as global - -> [TcTyVar s] -- The original signature type variables - -> TcType s -- signature type (for err msg) - -> TcM s () - -checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau - = -- Check point (c) + = tcGetGlobalTyVars `thenNF_Tc` \ globals -> + let + mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars + in + -- TEMPORARY FIX + -- Until the final Bind-handling stuff is in, several type signatures in the same + -- bindings group can cause the signature type variable from the different + -- signatures to be unified. So we still need to zonk and check point (b). + -- Remove when activating the new binding code + mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys -> + checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys)) + (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' -> + failTc (badMatchErr sig_tau sig_tau') + ) `thenTc_` + + + -- Check point (c) -- We want to report errors in terms of the original signature tyvars, -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond -- 1-1 with sig_tyvars, so we can just map back. checkTc (null mono_tyvars) (notAsPolyAsSigErr sig_tau mono_tyvars) - where - mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars \end{code} @@ -383,9 +414,8 @@ Contexts and errors \begin{code} notAsPolyAsSigErr sig_tau mono_tyvars sty = ppHang (ppStr "A type signature is more polymorphic than the inferred type") - 4 (ppAboves [ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)", - ppHang (ppStr "Monomorphic type variable(s):") - 4 (interpp'SP sty mono_tyvars), + 4 (ppAboves [ppStr "Some type variables in the inferred type can't be forall'd, namely:", + interpp'SP sty mono_tyvars, ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction" ]) \end{code}