+ ; return (binds, poly_ids) }
+ where
+ binder_names = collectHsBindListBinders bind_list
+ loc = getLoc (head bind_list)
+ -- TODO: location a bit awkward, but the mbinds have been
+ -- dependency analysed and may no longer be adjacent
+
+------------------
+tcPolyNoGen
+ :: TcSigFun -> PragFun
+ -> RecFlag -- Whether it's recursive after breaking
+ -- dependencies based on type signatures
+ -> [LHsBind Name]
+ -> TcM (LHsBinds TcId, [TcId])
+-- No generalisation whatsoever
+
+tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
+ = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn)
+ rec_tc bind_list
+ ; mono_ids' <- mapM tc_mono_info mono_infos
+ ; return (binds', mono_ids') }
+ where
+ tc_mono_info (name, _, mono_id)
+ = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
+ -- Zonk, mainly to expose unboxed types to checkStrictBinds
+ ; let mono_id' = setIdType mono_id mono_ty'
+ ; _specs <- tcSpecPrags mono_id' (prag_fn name)
+ ; return mono_id' }
+ -- NB: tcPrags generates error messages for
+ -- specialisation pragmas for non-overloaded sigs
+ -- Indeed that is why we call it here!
+ -- So we can safely ignore _specs
+
+------------------
+tcPolyCheck :: TcSigInfo -> PragFun
+ -> RecFlag -- Whether it's recursive after breaking
+ -- dependencies based on type signatures
+ -> [LHsBind Name]
+ -> TcM (LHsBinds TcId, [TcId])
+-- There is just one binding,
+-- it binds a single variable,
+-- it has a signature,
+tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
+ , sig_theta = theta, sig_loc = loc })
+ prag_fn rec_tc bind_list
+ = do { ev_vars <- newEvVars theta
+
+ ; let skol_info = SigSkol (FunSigCtxt (idName id))
+ ; (ev_binds, (binds', [mono_info]))
+ <- checkConstraints skol_info emptyVarSet tvs ev_vars $
+ tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
+ tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
+
+ ; export <- mkExport prag_fn tvs theta mono_info
+
+ ; let (_, poly_id, _, _) = export
+ abs_bind = L loc $ AbsBinds
+ { abs_tvs = tvs
+ , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
+ , abs_exports = [export], abs_binds = binds' }
+ ; return (unitBag abs_bind, [poly_id]) }
+
+------------------
+tcPolyInfer
+ :: TopLevelFlag
+ -> Bool -- True <=> apply the monomorphism restriction
+ -> TcSigFun -> PragFun
+ -> RecFlag -- Whether it's recursive after breaking
+ -- dependencies based on type signatures
+ -> [LHsBind Name]
+ -> TcM (LHsBinds TcId, [TcId])
+tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
+ = do { ((binds', mono_infos), wanted)
+ <- captureConstraints $
+ tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
+
+ ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
+
+ ; let get_tvs | isTopLevel top_lvl = tyVarsOfType
+ | otherwise = exactTyVarsOfType
+ -- See Note [Silly type synonym] in TcType
+ tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos
+
+ ; (qtvs, givens, ev_binds) <- simplifyInfer mono tau_tvs wanted
+
+ ; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens))
+ mono_infos
+
+ ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
+ ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
+
+ ; loc <- getSrcSpanM
+ ; let abs_bind = L loc $ AbsBinds { abs_tvs = qtvs
+ , abs_ev_vars = givens, abs_ev_binds = ev_binds
+ , abs_exports = exports, abs_binds = binds' }
+
+ ; return (unitBag abs_bind, poly_ids) -- poly_ids are guaranteed zonked by mkExport
+ }