From: simonpj@microsoft.com <unknown>
Date: Wed, 25 Apr 2007 07:47:19 +0000 (+0000)
Subject: Give the inferred type when warning of a missing type-signature (Trac #1256)
X-Git-Tag: 2007-05-06~124
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=bb7d80b3b8d1396d481d3b24302bee24a3d92f71

Give the inferred type when warning of a missing type-signature (Trac #1256)
---

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index a96c63f..d7a5952 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -178,20 +178,7 @@ rnTopBindsBoot (ValBindsIn mbinds sigs)
 	; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
 
 rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
-rnTopBindsSrc binds@(ValBindsIn mbinds _)
-  = do	{ (binds', dus) <- rnValBinds noTrim binds
-
-		-- Warn about missing signatures, 
-	; let	{ ValBindsOut _ sigs' = binds'
-		; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs']
-		; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars }
-
-	; warn_missing_sigs <- doptM Opt_WarnMissingSigs
-	; ifM (warn_missing_sigs)
-	      (mappM_ missingSigWarn (nameSetToList un_sigd_bndrs))
-
-	; return (binds', dus)
-	}
+rnTopBindsSrc binds = rnValBinds noTrim binds
 \end{code}
 
 
@@ -647,12 +634,6 @@ unknownSigErr (L loc sig)
   where
     what_it_is = hsSigDoc sig
 
-missingSigWarn var
-  = addWarnAt (mkSrcSpan loc loc) $
-      sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
-  where 
-    loc = nameSrcLoc var  -- TODO: make a proper span
-
 methodBindErr mbind
  =  hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))
        2 (ppr mbind)
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 5d9dbb8..96b2ed8 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -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}
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 7928289..f0303c1 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -725,9 +725,12 @@ checkTc False err = failWithTc err
 
 \begin{code}
 addWarnTc :: Message -> TcM ()
-addWarnTc msg
+addWarnTc msg = do { env0 <- tcInitTidyEnv 
+		   ; addWarnTcM (env0, msg) }
+
+addWarnTcM :: (TidyEnv, Message) -> TcM ()
+addWarnTcM (env0, msg)
  = do { ctxt <- getErrCtxt ;
-	env0 <- tcInitTidyEnv ;
 	ctxt_msgs <- do_ctxt env0 ctxt ;
 	addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
 
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index a82cd52..82d7afe 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -1006,7 +1006,8 @@ f foo = foo { x = 6 }
 
 	  <para>If you would like GHC to check that every top-level
           function/value has a type signature, use the
-          <option>-fwarn-missing-signatures</option> option.  This
+          <option>-fwarn-missing-signatures</option> option.  As part of
+	    the warning GHC also reports the inferred type.  The
           option is off by default.</para>
 	</listitem>
       </varlistentry>