-- Extend the envt right away with all
-- the Ids declared with type signatures
- ; gla_exts <- doptM Opt_GlasgowExts
+ ; poly_rec <- doptM Opt_RelaxedPolyRec
; (binds', thing) <- tcExtendIdEnv poly_ids $
- tc_val_binds gla_exts top_lvl sig_fn prag_fn
+ tc_val_binds poly_rec top_lvl sig_fn prag_fn
binds thing_inside
; return (ValBindsOut binds' sigs, thing) }
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-tc_val_binds gla_exts top_lvl sig_fn prag_fn [] thing_inside
+tc_val_binds poly_rec top_lvl sig_fn prag_fn [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
-tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside
+tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
- <- tc_group gla_exts top_lvl sig_fn prag_fn group $
- tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside
+ <- tc_group poly_rec top_lvl sig_fn prag_fn group $
+ tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
------------------------
-- We get a list of groups back, because there may
-- be specialisations etc as well
-tc_group gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
+tc_group poly_rec top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
-- A single non-recursive binding
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
= do { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside
; return ([(NonRecursive, b) | b <- binds], thing) }
-tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
- | not gla_exts -- Recursive group, normal Haskell 98 route
+tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+ | not poly_rec -- Recursive group, normal Haskell 98 route
= do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside
; return ([(Recursive, unionManyBags binds1)], thing) }
-- BUILD THE POLYMORPHIC RESULT IDs
; let dict_ids = map instToId dicts
- ; exports <- mapM (mkExport prag_fn tyvars_to_gen (map idType dict_ids))
+ ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map idType dict_ids))
mono_bind_infos
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
--------------
-mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
+mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
+ -> MonoBindInfo
-> TcM ([TyVar], Id, Id, [LPrag])
-- mkExport generates exports with
-- zonked type variables,
-- Pre-condition: the inferred_tvs are already zonked
-mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
- = do { (tvs, poly_id) <- mk_poly_id mb_sig
+mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+ = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs
+ ; let warn = isTopLevel top_lvl && warn_missing_sigs
+ ; (tvs, poly_id) <- mk_poly_id warn mb_sig
; poly_id' <- zonkId poly_id
; prags <- tcPrags poly_id' (prag_fn poly_name)
where
poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
- mk_poly_id Nothing = return (inferred_tvs, mkLocalId poly_name poly_ty)
- mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
- ; return (tvs, sig_id sig) }
+ mk_poly_id warn Nothing = do { missingSigWarn warn poly_name poly_ty
+ ; return (inferred_tvs, mkLocalId poly_name poly_ty) }
+ mk_poly_id warn (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
+ ; return (tvs, sig_id sig) }
zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
genCtxt binder_names
= ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
+
+missingSigWarn False name ty = return ()
+missingSigWarn True name ty
+ = do { env0 <- tcInitTidyEnv
+ ; let (env1, tidy_ty) = tidyOpenType env0 ty
+ ; addWarnTcM (env1, mk_msg tidy_ty) }
+ where
+ mk_msg ty = vcat [ptext SLIT("Definition but no type signature for") <+> quotes (ppr name),
+ sep [ptext SLIT("Inferred type:") <+> ppr name <+> dcolon <+> ppr ty]]
\end{code}