-tcMonoBinds :: [LHsBind Name]
- -> TcSigFun
- -> RecFlag -- Whether the binding is recursive for typechecking purposes
- -- i.e. the binders are mentioned in their RHSs, and
- -- we are not resuced by a type signature
- -> TcM (LHsBinds TcId, [MonoBindInfo])
-
-tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
- fun_matches = matches, bind_fvs = fvs })]
- sig_fn -- Single function binding,
- NonRecursive -- binder isn't mentioned in RHS,
- | Nothing <- sig_fn name -- ...with no type signature
- = -- In this very special case we infer the type of the
- -- right hand side first (it may have a higher-rank type)
- -- and *then* make the monomorphic Id for the LHS
- -- e.g. f = \(x::forall a. a->a) -> <body>
- -- We want to infer a higher-rank type for f
- setSrcSpan b_loc $
- do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches)
-
- -- Check for an unboxed tuple type
- -- f = (# True, False #)
- -- Zonk first just in case it's hidden inside a meta type variable
- -- (This shows up as a (more obscure) kind error
- -- in the 'otherwise' case of tcMonoBinds.)
- ; zonked_rhs_ty <- zonkTcType rhs_ty
- ; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
- (unboxedTupleErr name zonked_rhs_ty)
-
- ; mono_name <- newLocalName name
- ; let mono_id = mkLocalId mono_name zonked_rhs_ty
- ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
- fun_matches = matches', bind_fvs = fvs,
- fun_co_fn = co_fn })),
- [(name, Nothing, mono_id)]) }
-
-tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
- fun_matches = matches, bind_fvs = fvs })]
- sig_fn -- Single function binding
- non_rec
- | Just scoped_tvs <- sig_fn name -- ...with a type signature
- = -- When we have a single function binding, with a type signature
- -- we can (a) use genuine, rigid skolem constants for the type variables
- -- (b) bring (rigid) scoped type variables into scope
- setSrcSpan b_loc $
- do { tc_sig <- tcInstSig True name scoped_tvs
- ; mono_name <- newLocalName name
- ; let mono_ty = sig_tau tc_sig
- mono_id = mkLocalId mono_name mono_ty
- rhs_tvs = [ (name, mkTyVarTy tv)
- | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
-
- ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
- tcMatchesFun mono_name matches mono_ty
-
- ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
- fun_infix = inf, fun_matches = matches',
- bind_fvs = placeHolderNames, fun_co_fn = co_fn }
- ; return (unitBag (L b_loc fun_bind'),
- [(name, Just tc_sig, mono_id)]) }
-
-tcMonoBinds binds sig_fn non_rec
- = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
-
- -- Bring the monomorphic Ids, into scope for the RHSs
- ; let mono_info = getMonoBindInfo tc_binds
- rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
- -- A monomorphic binding for each term variable that lacks
- -- a type sig. (Ones with a sig are already in scope.)
-
- ; binds' <- tcExtendIdEnv2 rhs_id_env $
- traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id)
- | (n,id) <- rhs_id_env]) `thenM_`
- mapM (wrapLocM tcRhs) tc_binds
- ; return (listToBag binds', mono_info) }
+tcMonoBinds :: TcSigFun
+ -> Bool -- True <=> no generalisation will be done for this binding
+ -> RecFlag -- Whether the binding is recursive for typechecking purposes
+ -- i.e. the binders are mentioned in their RHSs, and
+ -- we are not resuced by a type signature
+ -> [LHsBind Name]
+ -> TcM (LHsBinds TcId, [MonoBindInfo])
+
+tcMonoBinds sig_fn no_gen is_rec
+ [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
+ fun_matches = matches, bind_fvs = fvs })]
+ -- Single function binding,
+ | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
+ , Nothing <- sig_fn name -- ...with no type signature
+ = -- In this very special case we infer the type of the
+ -- right hand side first (it may have a higher-rank type)
+ -- and *then* make the monomorphic Id for the LHS
+ -- e.g. f = \(x::forall a. a->a) -> <body>
+ -- We want to infer a higher-rank type for f
+ setSrcSpan b_loc $
+ do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
+
+ ; mono_id <- newLetBndr no_gen name rhs_ty
+ ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
+ fun_matches = matches', bind_fvs = fvs,
+ fun_co_fn = co_fn, fun_tick = Nothing })),
+ [(name, Nothing, mono_id)]) }
+
+tcMonoBinds sig_fn no_gen _ binds
+ = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
+
+ -- Bring the monomorphic Ids, into scope for the RHSs
+ ; let mono_info = getMonoBindInfo tc_binds
+ rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
+ -- A monomorphic binding for each term variable that lacks
+ -- a type sig. (Ones with a sig are already in scope.)
+
+ ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
+ traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
+ | (n,id) <- rhs_id_env]
+ mapM (wrapLocM tcRhs) tc_binds
+ ; return (listToBag binds', mono_info) }