X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=351b6d8a2567987e1c3ecac285fb5438a9f5ad8a;hp=5d9dbb885a0a38badb0312aa31ba3bdf0e345234;hb=f6a68d3109f977fe4431df51d1412d916e7c08da;hpb=e5ca7e6e5137a2e6081717e5e90ca52a30840f68

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 5d9dbb8..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,7 +352,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 
 
 --------------
-mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
+mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
+	 -> MonoBindInfo
 	 -> TcM ([TyVar], Id, Id, [LPrag])
 -- mkExport generates exports with 
 --	zonked type variables, 
@@ -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) }
 
@@ -1144,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}