import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId
)
-import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, 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 )
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 )
-- 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
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
%************************************************************************
\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) ->
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
- tcSimplifyRestricted 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 = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
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)
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
sigContextsErr = ptext SLIT("Mismatched contexts")
sigContextsCtxt s1 s2
- = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
- quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
- 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
+ = vcat [ptext SLIT("When matching the contexts of the signatures for"),
+ nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
+ ppr s2 <+> dcolon <+> ppr (idType s2)]),
+ ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
-----------------------------------------------
unliftedBindErr flavour mbind
projects / ghc-hetmet.git / blobdiff