- ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
- ; is_strict <- checkStrictBinds top_lvl rec_group binds'
- zonked_mono_tys mono_bind_infos
- ; if is_strict then
- do { extendLIEs lie_req
- ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
- mk_export (name, mb_sig, mono_id) mono_ty
- = ([], the_id, mono_id, noSpecPrags)
- -- ToDo: prags for unlifted bindings
- where
- the_id = case mb_sig of
- Just sig -> sig_id sig
- Nothing -> mkLocalId name mono_ty
-
- ; return ( unitBag $ L loc $ AbsBinds [] [] exports binds',
- [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
-
- else do -- The normal lifted case: GENERALISE
- { dflags <- getDOpts
- ; (tyvars_to_gen, dicts, dict_binds)
- <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
- generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
-
- -- BUILD THE POLYMORPHIC RESULT IDs
- ; let dict_vars = map instToVar dicts -- May include equality constraints
- ; exports <- mapM (mkExport top_lvl rec_group (length mono_bind_infos > 1)
- prag_fn tyvars_to_gen (map varType dict_vars))
- mono_bind_infos
-
- ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
- ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids))
-
- ; let abs_bind = L loc $ AbsBinds tyvars_to_gen
- dict_vars exports
- (dict_binds `unionBags` binds')
-
- ; return (unitBag abs_bind, poly_ids) -- poly_ids are guaranteed zonked by mkExport
- } }
+ ; checkStrictBinds top_lvl rec_group bind_list poly_ids
+
+ -- Warn about missing signatures
+ -- Do this only when we we have a type to offer
+ ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
+ ; when (isTopLevel top_lvl && warn_missing_sigs) $
+ mapM_ missingSigWarn (filter no_sig poly_ids)
+
+ ; return (binds, poly_ids) }
+ where
+ no_sig id = isNothing (sig_fn (idName id))
+
+ 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 the group is really recursive
+ -> 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_group rec_tc bind_list
+ = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn True 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'
+ ; (mono_id'', _specs) <- tcPrags rec_group False False
+ mono_id' (prag_fn name)
+ ; return mono_id'' }
+ -- NB: tcPrags generates and error message for
+ -- specialisation pragmas for non-overloaded sigs
+ -- So we can safely ignore _specs
+
+------------------
+tcPolyCheck :: TcSigInfo -> PragFun
+ -> RecFlag -- Whether the group is really recursive
+ -> 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_group 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) False rec_tc bind_list
+
+ ; export <- mkExport rec_group False 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 the group is really recursive
+ -> 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_group rec_tc bind_list
+ = do { ((binds', mono_infos), wanted)
+ <- getConstraints $
+ tcMonoBinds sig_fn False 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 rec_group (length mono_infos > 1)
+ 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
+ }