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}
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',
:: 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
-- 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)
-- 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.
-> 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}
\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}
projects / ghc-hetmet.git / blobdiff