+ -- SIMPLIFY THE LIE
+ tcExtendGlobalTyVars tyvars_not_to_gen (
+ let ips = getIPsOfLIE lie_avail_req in
+ if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
+ -- No polymorphism, and no IPs, so no need to simplify context
+ returnTc (lie_req, EmptyMonoBinds, [])
+ else
+ case maybe_sig_theta of
+ Nothing ->
+ -- No signatures, so just simplify the lie
+ -- NB: no signatures => no polymorphic recursion, so no
+ -- need to use lie_avail (which will be empty anyway)
+ tcSimplify (text "tcBinds1" <+> ppr binder_names)
+ real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
+ returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
+
+ Just (sig_theta, lie_avail) ->
+ -- There are signatures, and their context is sig_theta
+ -- Furthermore, lie_avail is an LIE containing the 'method insts'
+ -- for the things bound here
+
+ zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' ->
+ newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
+ -- It's important that sig_theta is 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
+
+ let
+ -- The "givens" is the stuff available. We get that from
+ -- the context of the type signature, BUT ALSO the lie_avail
+ -- so that polymorphic recursion works right (see comments at end of fn)
+ givens = dicts_sig `plusLIE` lie_avail
+ in
+
+ -- Check that the needed dicts can be expressed in
+ -- terms of the signature ones
+ tcAddErrCtxt (bindSigsCtxt tysig_names) $
+ tcSimplifyAndCheck
+ (ptext SLIT("type signature for") <+> pprQuotedList binder_names)
+ real_tyvars_to_gen givens lie_req `thenTc` \ (lie_free, dict_binds) ->
+
+ returnTc (lie_free, dict_binds, dict_ids)
+
+ ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
+
+ -- GET THE FINAL MONO_ID_TYS
+ zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
+
+
+ -- CHECK FOR BOGUS UNPOINTED BINDINGS
+ (if any isUnLiftedType zonked_mono_id_types then
+ -- Unlifted bindings must be non-recursive,
+ -- not top level, and non-polymorphic
+ checkTc (isNotTopLevel top_lvl)
+ (unliftedBindErr "Top-level" mbind) `thenTc_`
+ checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
+ (unliftedBindErr "Recursive" mbind) `thenTc_`
+ checkTc (null real_tyvars_to_gen_list)
+ (unliftedBindErr "Polymorphic" mbind)
+ else
+ returnTc ()
+ ) `thenTc_`
+
+ ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
+ -- The instCantBeGeneralised stuff in tcSimplify should have
+ -- already raised an error if we're trying to generalise an
+ -- unlifted tyvar (NB: unlifted tyvars are always introduced
+ -- along with a class constraint) and it's better done there
+ -- because we have more precise origin information.
+ -- That's why we just use an ASSERT here.
+
+
+ -- BUILD THE POLYMORPHIC RESULT IDs
+ mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
+ let
+ exports = zipWith mk_export binder_names zonked_mono_ids
+ dict_tys = map idType dicts_bound
+
+ 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
+
+ mk_export binder_name zonked_mono_id
+ = (tyvars,
+ attachNoInlinePrag no_inlines poly_id,
+ zonked_mono_id)
+ where
+ (tyvars, poly_id) =
+ case maybeSig tc_ty_sigs binder_name of
+ Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
+ (sig_tyvars, sig_poly_id)
+ Nothing -> (real_tyvars_to_gen_list, new_poly_id)
+
+ new_poly_id = mkVanillaId binder_name poly_ty
+ poly_ty = mkForAllTys real_tyvars_to_gen_list
+ $ mkFunTys dict_tys
+ $ idType (zonked_mono_id)
+ -- It's important to build a fully-zonked poly_ty, because
+ -- we'll slurp out its free type variables when extending the
+ -- local environment (tcExtendLocalValEnv); if it's not zonked
+ -- it appears to have free tyvars that aren't actually free
+ -- at all.
+
+ pat_binders :: [Name]
+ pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
+ in
+ -- CHECK FOR UNLIFTED BINDERS IN PATTERN BINDINGS
+ mapTc (\id -> checkTc (not (idName id `elem` pat_binders
+ && isUnLiftedType (idType id)))
+ (unliftedPatBindErr id)) zonked_mono_ids
+ `thenTc_`
+
+ -- BUILD RESULTS
+ returnTc (
+ -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
+ AbsBinds real_tyvars_to_gen_list
+ dicts_bound
+ exports
+ inlines
+ (dict_binds `andMonoBinds` mbind'),
+ lie_free,
+ [poly_id | (_, poly_id, _) <- exports]
+ )