-tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
- = let
- bind_list = bagToList binds
- binder_names = collectHsBindBinders binds
- loc = getLoc (head bind_list)
- -- TODO: location a bit awkward, but the mbinds have been
- -- dependency analysed and may no longer be adjacent
- in
- -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
- setSrcSpan loc $
- recoverM (recoveryCode binder_names sig_fn) $ do
-
- { traceTc (ptext SLIT("------------------------------------------------"))
- ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
-
- -- TYPECHECK THE BINDINGS
- ; ((binds', mono_bind_infos), lie_req)
- <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
-
- -- CHECK FOR UNLIFTED BINDINGS
- -- These must be non-recursive etc, and are not generalised
- -- They desugar to a case expression in the end
- ; 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, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
- mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, [])
- -- ToDo: prags for unlifted bindings
-
- ; 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, dict_binds, dict_ids)
- <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
- generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
-
- -- FINALISE THE QUANTIFIED TYPE VARIABLES
- -- The quantified type variables often include meta type variables
- -- we want to freeze them into ordinary type variables, and
- -- default their kind (e.g. from OpenTypeKind to TypeKind)
- ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
-
- -- BUILD THE POLYMORPHIC RESULT IDs
- ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
- 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_ids exports
- (dict_binds `unionBags` binds')
-
- ; return ([unitBag abs_bind], poly_ids) -- poly_ids are guaranteed zonked by mkExport
- } }
+tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
+ = setSrcSpan loc $
+ recoverM (recoveryCode binder_names sig_fn) $ do
+ -- Set up main recoer; take advantage of any type sigs
+
+ { traceTc "------------------------------------------------" empty
+ ; traceTc "Bindings for" (ppr binder_names)
+
+ ; tc_sig_fn <- tcInstSigs sig_fn binder_names
+
+ ; dflags <- getDOpts
+ ; let plan = decideGeneralisationPlan dflags top_lvl binder_names bind_list tc_sig_fn
+ ; traceTc "Generalisation plan" (ppr plan)
+ ; (binds, poly_ids) <- case plan of
+ NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list
+ InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_group rec_tc bind_list
+ CheckGen sig -> tcPolyCheck sig prag_fn rec_group rec_tc bind_list
+
+ -- Check whether strict bindings are ok
+ -- These must be non-recursive etc, and are not generalised
+ -- They desugar to a case expression in the end
+ ; 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
+ }