+tcBindWithSigs
+ :: TopLevelFlag
+ -> RenamedMonoBinds
+ -> [TcSigInfo]
+ -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
+ -> RecFlag
+ -> TcM (TcMonoBinds, LIE, [TcId])
+
+tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
+ = recoverTc (
+ -- If typechecking the binds fails, then return with each
+ -- signature-less binder given type (forall a.a), to minimise subsequent
+ -- error messages
+ newTyVar liftedTypeKind `thenNF_Tc` \ alpha_tv ->
+ let
+ forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
+ binder_names = collectMonoBinders mbind
+ poly_ids = map mk_dummy binder_names
+ mk_dummy name = case maybeSig tc_ty_sigs name of
+ Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
+ Nothing -> mkLocalId name forall_a_a -- No signature
+ in
+ returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
+ ) $
+
+ -- 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)
+ 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) ->
+
+
+ -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
+ -- This commits any unbound kind variables to boxed kind, by unification
+ -- It's important that the final quanfified type variables
+ -- are fully zonked, *including boxity*, because they'll be
+ -- included in the forall types of the polymorphic Ids.
+ -- At calls of these Ids we'll instantiate fresh type variables from
+ -- them, and we use their boxity then.
+ mapNF_Tc zonkTcTyVarToTyVar tc_tyvars_to_gen `thenNF_Tc` \ real_tyvars_to_gen ->
+
+ -- ZONK THE Ids
+ -- It's important that the dict Ids are zonked, including the boxity set
+ -- in the previous step, because they are later used to form the type of
+ -- the polymorphic thing, and forall-types must be zonked so far as
+ -- their bound variables are concerned
+ mapNF_Tc zonkId dict_ids `thenNF_Tc` \ zonked_dict_ids ->
+ mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
+
+ -- CHECK FOR BOGUS UNLIFTED BINDINGS
+ checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids `thenTc_`
+
+ -- BUILD THE POLYMORPHIC RESULT IDs
+ let
+ 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
+
+ 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, new_poly_id)
+
+ new_poly_id = mkLocalId binder_name poly_ty
+ poly_ty = mkForAllTys real_tyvars_to_gen
+ $ 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.
+ in
+
+ traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
+ exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_`
+
+ -- BUILD RESULTS
+ returnTc (
+ AbsBinds real_tyvars_to_gen
+ zonked_dict_ids
+ exports
+ inlines
+ (dict_binds `andMonoBinds` mbind'),
+ lie_free,
+ [poly_id | (_, poly_id, _) <- exports]
+ )
+
+attachNoInlinePrag no_inlines bndr
+ = case lookupFM no_inlines (idName bndr) of
+ Just prag -> bndr `setInlinePragma` prag
+ Nothing -> bndr
+
+checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids
+ = ASSERT( not (any ((== 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
+ -- 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.
+
+ -- Check that pattern-bound variables are not unlifted
+ (if or [ (idName id `elem` pat_binders) && isUnLiftedType (idType id)
+ | id <- zonked_mono_ids ] then
+ addErrTc (unliftedBindErr "Pattern" mbind)
+ else
+ returnTc ()
+ ) `thenTc_`
+
+ -- Unlifted bindings must be non-recursive,
+ -- not top level, non-polymorphic, and not pattern bound
+ if any (isUnLiftedType . idType) zonked_mono_ids then
+ checkTc (isNotTopLevel top_lvl)
+ (unliftedBindErr "Top-level" mbind) `thenTc_`
+ checkTc (isNonRec is_rec)
+ (unliftedBindErr "Recursive" mbind) `thenTc_`
+ checkTc (null real_tyvars_to_gen)
+ (unliftedBindErr "Polymorphic" mbind)
+ else
+ returnTc ()
+
+ where
+ pat_binders :: [Name]
+ pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
+
+ justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
+ justPatBindings (AndMonoBinds b1 b2) binds =
+ justPatBindings b1 (justPatBindings b2 binds)
+ justPatBindings other_bind binds = binds