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 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 Util ( isIn, equalLength )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel,
+ isAlwaysActive )
import FiniteMap ( listToFM, lookupFM )
import Outputable
\end{code}
-- 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) ->
exports = zipWith mk_export binder_names zonked_mono_ids
dict_tys = map idType zonked_dict_ids
- inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
- no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
- [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase])
- -- "INLINE n foo" means inline foo, but not until at least phase n
- -- "NOINLINE n foo" means don't inline foo until at least phase n, and even
- -- then only if it is small enough etc.
- -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
- -- See comments in CoreUnfold.blackListed for the Authorised Version
+ inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
+ no_inlines = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs,
+ not (isAlwaysActive phase)]
+ -- AlwaysActive is the default, so don't bother with them
mk_export binder_name zonked_mono_id
= (tyvars,
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
-- 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
returnTc (sig_avails, map instToId sig_dicts)
where
sig1_dict_tys = map mkPredTy theta1
- n_sig1_theta = length theta1
sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (sigContextsCtxt id1 id) $
- checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
+ = tcAddErrCtxt (sigContextsCtxt id1 id) $
+ checkTc (equalLength theta theta1) sigContextsErr `thenTc_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
checkSigsTyVars sigs = mapTc_ check_one sigs
newTyVarTy kind `thenNF_Tc` \ pat_ty ->
-- Now typecheck the pattern
- -- We don't support binding fresh type variables in the
- -- pattern of a pattern binding. For example, this is illegal:
+ -- We don't support binding fresh (not-already-in-scope) scoped
+ -- type variables in the pattern of a pattern binding.
+ -- For example, this is illegal:
-- (x::a, y::b) = e
-- whereas this is ok
-- (x::Int, y::Bool) = e
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
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 = pprWithCommas ppr bndrs
\end{code}
projects / ghc-hetmet.git / blobdiff