X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=351b6d8a2567987e1c3ecac285fb5438a9f5ad8a;hb=b99310f05faee2abec850da4349fcd5c0498f7ca;hp=9c176d0f94bd1f7bcb18151531acc5d48b0ad278;hpb=2423c249f5ca7785d0ec89eb33e72662da7561c1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 9c176d0..351b6d8 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -162,9 +162,9 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside -- 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) } @@ -176,14 +176,14 @@ tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- 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) } ------------------------ @@ -195,15 +195,15 @@ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- 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) } @@ -337,7 +337,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -- 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] @@ -352,8 +352,9 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -------------- -mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo - -> TcM ([TyVar], Id, Id, [Prag]) +mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] + -> MonoBindInfo + -> TcM ([TyVar], Id, Id, [LPrag]) -- mkExport generates exports with -- zonked type variables, -- zonked poly_ids @@ -365,8 +366,10 @@ mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo -- 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) @@ -376,9 +379,10 @@ mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) 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) } @@ -393,12 +397,11 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] env = foldl add emptyNameEnv prs add env (n,p) = extendNameEnv_Acc (:) singleton env n p -tcPrags :: Id -> [LSig Name] -> TcM [Prag] -tcPrags poly_id prags = mapM tc_prag prags +tcPrags :: Id -> [LSig Name] -> TcM [LPrag] +tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags where - tc_prag (L loc prag) = setSrcSpan loc $ - addErrCtxt (pragSigCtxt prag) $ - tcPrag poly_id prag + tc_prag prag = addErrCtxt (pragSigCtxt prag) $ + tcPrag poly_id prag pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) @@ -1145,4 +1148,13 @@ restrictedBindCtxtErr binder_names 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}