Move checking for missing signatures to RnNames.reportUnusedNames
authorEric Seidel <gridaphobe@gmail.com>
Mon, 7 Dec 2015 11:42:38 +0000 (12:42 +0100)
committerBen Gamari <ben@smart-cactus.org>
Mon, 7 Dec 2015 12:09:27 +0000 (13:09 +0100)
Checking for missing signatures before renaming the export list is
prone to errors, so we now perform the check in `reportUnusedNames` at
which point everything has been renamed.

Test Plan: validate, new test case is T10908

Reviewers: goldfire, simonpj, austin, bgamari

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1561

GHC Trac Issues: #10908

compiler/rename/RnNames.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcRnDriver.hs
testsuite/tests/warnings/should_compile/T10908.hs [new file with mode: 0644]
testsuite/tests/warnings/should_compile/all.T

index 81ae70b..d61c299 100644 (file)
@@ -43,6 +43,8 @@ import Util
 import FastString
 import FastStringEnv
 import ListSetOps
+import Id
+import Type
 
 import Control.Monad
 import Data.Either      ( partitionEithers, isRight, rights )
@@ -1471,7 +1473,8 @@ reportUnusedNames :: Maybe (Located [LIE RdrName])  -- Export list
 reportUnusedNames _export_decls gbl_env
   = do  { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
         ; warnUnusedImportDecls gbl_env
-        ; warnUnusedTopBinds unused_locals }
+        ; warnUnusedTopBinds unused_locals
+        ; warnMissingSigs gbl_env }
   where
     used_names :: NameSet
     used_names = findUses (tcg_dus gbl_env) emptyNameSet
@@ -1546,6 +1549,64 @@ warnUnusedImportDecls gbl_env
        ; whenGOptM Opt_D_dump_minimal_imports $
          printMinimalImports usage }
 
+-- | Warn the user about top level binders that lack type signatures.
+warnMissingSigs :: TcGblEnv -> RnM ()
+warnMissingSigs gbl_env
+  = do { let exports = availsToNameSet (tcg_exports gbl_env)
+             sig_ns = tcg_sigs gbl_env
+             binds = tcg_binds gbl_env
+
+         -- Warn about missing signatures
+         -- Do this only when we we have a type to offer
+       ; warn_missing_sigs  <- woptM Opt_WarnMissingSigs
+       ; warn_only_exported <- woptM Opt_WarnMissingExportedSigs
+
+       ; let sig_warn
+               | warn_only_exported = topSigWarnIfExported exports sig_ns
+               | warn_missing_sigs  = topSigWarn sig_ns
+               | otherwise          = noSigWarn
+
+       ; sig_warn (collectHsBindsBinders binds) }
+
+type SigWarn = [Id] -> RnM ()
+     -- Missing-signature warning
+
+noSigWarn :: SigWarn
+noSigWarn _ = return ()
+
+topSigWarnIfExported :: NameSet -> NameSet -> SigWarn
+topSigWarnIfExported exported sig_ns ids
+  = mapM_ (topSigWarnIdIfExported exported sig_ns) ids
+
+topSigWarnIdIfExported :: NameSet -> NameSet -> Id -> RnM ()
+topSigWarnIdIfExported exported sig_ns id
+  | getName id `elemNameSet` exported
+  = topSigWarnId sig_ns id
+  | otherwise
+  = return ()
+
+topSigWarn :: NameSet -> SigWarn
+topSigWarn sig_ns ids = mapM_ (topSigWarnId sig_ns) ids
+
+topSigWarnId :: NameSet -> Id -> RnM ()
+-- The NameSet is the Ids that *lack* a signature
+-- We have to do it this way round because there are
+-- lots of top-level bindings that are generated by GHC
+-- and that don't have signatures
+topSigWarnId sig_ns id
+  | idName id `elemNameSet` sig_ns = warnMissingSig msg id
+  | otherwise                      = return ()
+  where
+    msg = ptext (sLit "Top-level binding with no type signature:")
+
+warnMissingSig :: SDoc -> Id -> RnM ()
+warnMissingSig msg id
+  = do  { env <- tcInitTidyEnv
+        ; let (_, tidy_ty) = tidyOpenType env (idType id)
+        ; addWarnAt (getSrcSpan id) (mk_msg tidy_ty) }
+  where
+    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
+
 {-
 Note [The ImportMap]
 ~~~~~~~~~~~~~~~~~~~~
index 6575082..5c6593a 100644 (file)
@@ -58,7 +58,7 @@ import Util
 import BasicTypes
 import Outputable
 import FastString
-import Type(mkStrLitTy)
+import Type(mkStrLitTy, tidyOpenType)
 import PrelNames( mkUnboundName, gHC_PRIM )
 import TcValidity (checkValidType)
 
@@ -728,6 +728,10 @@ mkExport prag_fn qtvs theta mono_info@(poly_name, mb_sig, mono_id)
                                            -- e..g infer  x :: forall a. F a -> Int
                   else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
                        tcSubType_NC sig_ctxt sel_poly_ty poly_ty
+
+        ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
+        ; when warn_missing_sigs $ localSigWarn poly_id mb_sig
+
         ; return (ABE { abe_wrap = wrap
                         -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
                       , abe_poly = poly_id
@@ -852,6 +856,24 @@ mk_inf_msg poly_name poly_ty tidy_env
                        , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
       ; return (tidy_env1, msg) }
 
+
+-- | Warn the user about polymorphic local binders that lack type signatures.
+localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM ()
+localSigWarn id mb_sig
+  | Just _ <- mb_sig               = return ()
+  | not (isSigmaTy (idType id))    = return ()
+  | otherwise                      = warnMissingSig msg id
+  where
+    msg = ptext (sLit "Polymorphic local binding with no type signature:")
+
+warnMissingSig :: SDoc -> Id -> TcM ()
+warnMissingSig msg id
+  = do  { env0 <- tcInitTidyEnv
+        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
+        ; addWarnTcM (env1, mk_msg tidy_ty) }
+  where
+    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
+
 {-
 Note [Partial type signatures and generalisation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 39e7f2d..2aeca15 100644 (file)
@@ -36,7 +36,6 @@ import TcRnMonad
 import PrelNames
 import TypeRep     -- We can see the representation of types
 import TcType
-import RdrName ( RdrName, rdrNameOcc )
 import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
 import TcEvidence
 import Coercion
@@ -46,7 +45,6 @@ import Type
 import ConLike
 import DataCon
 import Name
-import NameSet
 import Var
 import VarSet
 import VarEnv
@@ -56,7 +54,6 @@ import BasicTypes
 import Maybes
 import SrcLoc
 import Bag
-import FastString
 import Outputable
 import Util
 #if __GLASGOW_HASKELL__ < 709
@@ -299,8 +296,6 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 
 zonkTopDecls :: Bag EvBind
              -> LHsBinds TcId
-             -> Maybe (Located [LIE RdrName])
-             -> NameSet
              -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
              -> TcM ([Id],
                      Bag EvBind,
@@ -309,22 +304,9 @@ zonkTopDecls :: Bag EvBind
                      [LTcSpecPrag],
                      [LRuleDecl    Id],
                      [LVectDecl    Id])
-zonkTopDecls ev_binds binds export_ies sig_ns rules vects imp_specs fords
+zonkTopDecls ev_binds binds rules vects imp_specs fords
   = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
-
-         -- Warn about missing signatures
-         -- Do this only when we we have a type to offer
-        ; warn_missing_sigs <- woptM Opt_WarnMissingSigs
-        ; warn_only_exported <- woptM Opt_WarnMissingExportedSigs
-        ; let export_occs  = maybe emptyBag
-                                   (listToBag . concatMap (map rdrNameOcc . ieNames . unLoc) . unLoc)
-                                   export_ies
-              sig_warn
-                | warn_only_exported = topSigWarnIfExported export_occs sig_ns
-                | warn_missing_sigs  = topSigWarn sig_ns
-                | otherwise          = noSigWarn
-
-        ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
+        ; (env2, binds') <- zonkRecMonoBinds env1 binds
                         -- Top level is implicitly recursive
         ; rules' <- zonkRules env2 rules
         ; vects' <- zonkVects env2 vects
@@ -340,19 +322,15 @@ zonkLocalBinds env EmptyLocalBinds
 zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
   = panic "zonkLocalBinds" -- Not in typechecker output
 
-zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
-  = do  { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
-        ; let sig_warn | not warn_missing_sigs = noSigWarn
-                       | otherwise             = localSigWarn sig_ns
-              sig_ns = getTypeSigNames vb
-        ; (env1, new_binds) <- go env sig_warn binds
+zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
+  = do  { (env1, new_binds) <- go env binds
         ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
   where
-    go env []
+    go env []
       = return (env, [])
-    go env sig_warn ((r,b):bs)
-      = do { (env1, b')  <- zonkRecMonoBinds env sig_warn b
-           ; (env2, bs') <- go env1 sig_warn bs
+    go env ((r,b):bs)
+      = do { (env1, b')  <- zonkRecMonoBinds env b
+           ; (env2, bs') <- go env1 bs
            ; return (env2, (r,b'):bs') }
 
 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
@@ -368,112 +346,53 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
              return (IPBind n' e')
 
 ---------------------------------------------
-zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
-zonkRecMonoBinds env sig_warn binds
+zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
+zonkRecMonoBinds env binds
  = fixM (\ ~(_, new_binds) -> do
         { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
-        ; binds' <- zonkMonoBinds env1 sig_warn binds
+        ; binds' <- zonkMonoBinds env1 binds
         ; return (env1, binds') })
 
 ---------------------------------------------
-type SigWarn = Bool -> [Id] -> TcM ()
-     -- Missing-signature warning
-     -- The Bool is True for an AbsBinds, False otherwise
-
-noSigWarn :: SigWarn
-noSigWarn _ _ = return ()
-
-topSigWarnIfExported :: Bag OccName -> NameSet -> SigWarn
-topSigWarnIfExported exported sig_ns _ ids
-  = mapM_ (topSigWarnIdIfExported exported sig_ns) ids
-
-topSigWarnIdIfExported :: Bag OccName -> NameSet -> Id -> TcM ()
-topSigWarnIdIfExported exported sig_ns id
-  | getOccName id `elemBag` exported
-  = topSigWarnId sig_ns id
-  | otherwise
-  = return ()
-
-topSigWarn :: NameSet -> SigWarn
-topSigWarn sig_ns _ ids = mapM_ (topSigWarnId sig_ns) ids
-
-topSigWarnId :: NameSet -> Id -> TcM ()
--- The NameSet is the Ids that *lack* a signature
--- We have to do it this way round because there are
--- lots of top-level bindings that are generated by GHC
--- and that don't have signatures
-topSigWarnId sig_ns id
-  | idName id `elemNameSet` sig_ns = warnMissingSig msg id
-  | otherwise                      = return ()
-  where
-    msg = ptext (sLit "Top-level binding with no type signature:")
-
-localSigWarn :: NameSet -> SigWarn
-localSigWarn sig_ns is_abs_bind ids
-  | not is_abs_bind = return ()
-  | otherwise       = mapM_ (localSigWarnId sig_ns) ids
-
-localSigWarnId :: NameSet -> Id -> TcM ()
--- NameSet are the Ids that *have* type signatures
-localSigWarnId sig_ns id
-  | not (isSigmaTy (idType id))    = return ()
-  | idName id `elemNameSet` sig_ns = return ()
-  | otherwise                      = warnMissingSig msg id
-  where
-    msg = ptext (sLit "Polymorphic local binding with no type signature:")
-
-warnMissingSig :: SDoc -> Id -> TcM ()
-warnMissingSig msg id
-  = do  { env0 <- tcInitTidyEnv
-        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
-        ; addWarnTcM (env1, mk_msg tidy_ty) }
-  where
-    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
-
----------------------------------------------
-zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)
-zonkMonoBinds env sig_warn binds = mapBagM (zonk_lbind env sig_warn) binds
+zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
+zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
 
-zonk_lbind :: ZonkEnv -> SigWarn -> LHsBind TcId -> TcM (LHsBind Id)
-zonk_lbind env sig_warn = wrapLocM (zonk_bind env sig_warn)
+zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
+zonk_lbind env = wrapLocM (zonk_bind env)
 
-zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
-zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
+zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
   = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
-        ; sig_warn False (collectPatBinders new_pat)
         ; new_grhss <- zonkGRHSs env zonkLExpr grhss
         ; new_ty    <- zonkTcTypeToType env ty
         ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
 
-zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
+zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
   = do { new_var  <- zonkIdBndr env var
-       ; sig_warn False [new_var]
        ; new_expr <- zonkLExpr env expr
        ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }
 
-zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms
-                                     , fun_co_fn = co_fn })
+zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
+                            , fun_co_fn = co_fn })
   = do { new_var <- zonkIdBndr env var
-       ; sig_warn False [new_var]
        ; (env1, new_co_fn) <- zonkCoFn env co_fn
        ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
        ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                       , fun_co_fn = new_co_fn }) }
 
-zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
-                                 , abs_ev_binds = ev_binds
-                                 , abs_exports = exports
-                                 , abs_binds = val_binds })
+zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
+                        , abs_ev_binds = ev_binds
+                        , abs_exports = exports
+                        , abs_binds = val_binds })
   = ASSERT( all isImmutableTyVar tyvars )
     do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
        ; (env1, new_evs) <- zonkEvBndrsX env0 evs
        ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
          do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
-            ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
+            ; new_val_binds <- zonkMonoBinds env3 val_binds
             ; new_exports   <- mapM (zonkExport env3) exports
             ; return (new_val_binds, new_exports) }
-       ; sig_warn True (map abe_poly new_exports)
        ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                           , abs_ev_binds = new_ev_binds
                           , abs_exports = new_exports, abs_binds = new_val_bind }) }
@@ -487,13 +406,13 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                         , abe_mono = zonkIdOcc env mono_id
                         , abe_prags = new_prags })
 
-zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id
-                                              , psb_args = details
-                                              , psb_def = lpat
-                                              , psb_dir = dir }))
+zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
+                                    , psb_args = details
+                                    , psb_def = lpat
+                                    , psb_dir = dir }))
   = do { id' <- zonkIdBndr env id
        ; details' <- zonkPatSynDetails env details
-       ;(env1, lpat') <- zonkPat env lpat
+       ; (env1, lpat') <- zonkPat env lpat
        ; (_env2, dir') <- zonkPatSynDir env1 dir
        ; return $ PatSynBind $
                   bind { psb_id = L loc id'
index 27b8074..59f1ab8 100644 (file)
@@ -329,7 +329,7 @@ tcRnModuleTcRnM hsc_env hsc_src
                         tcRnHsBootDecls hsc_src local_decls
                    else
                         {-# SCC "tcRnSrcDecls" #-}
-                        tcRnSrcDecls explicit_mod_hdr export_ies local_decls ;
+                        tcRnSrcDecls explicit_mod_hdr local_decls ;
         setGblEnv tcg_env               $ do {
 
                 -- Process the export list
@@ -464,12 +464,11 @@ tcRnImports hsc_env import_decls
 -}
 
 tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
-             -> Maybe (Located [LIE RdrName])   -- Exports
              -> [LHsDecl RdrName]               -- Declarations
              -> TcM TcGblEnv
         -- Returns the variables free in the decls
         -- Reason: solely to report unused imports and bindings
-tcRnSrcDecls explicit_mod_hdr exports decls
+tcRnSrcDecls explicit_mod_hdr decls
  = do { -- Create a binding for $trModule
         -- Do this before processing any data type declarations,
         -- which need tcg_tr_module to be initialised
@@ -523,7 +522,6 @@ tcRnSrcDecls explicit_mod_hdr exports decls
         -- This pass also warns about missing type signatures
       ; let { TcGblEnv { tcg_type_env  = type_env,
                          tcg_binds     = binds,
-                         tcg_sigs      = sig_ns,
                          tcg_ev_binds  = cur_ev_binds,
                          tcg_imp_specs = imp_specs,
                          tcg_rules     = rules,
@@ -533,7 +531,7 @@ tcRnSrcDecls explicit_mod_hdr exports decls
 
       ; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
             <- {-# SCC "zonkTopDecls" #-}
-               zonkTopDecls all_ev_binds binds exports sig_ns rules vects
+               zonkTopDecls all_ev_binds binds rules vects
                             imp_specs fords ;
       ; traceTc "Tc11" empty
 
@@ -2115,7 +2113,7 @@ tcRnDeclsi :: HscEnv
            -> IO (Messages, Maybe TcGblEnv)
 tcRnDeclsi hsc_env local_decls
   = runTcInteractive hsc_env $
-    tcRnSrcDecls False Nothing local_decls
+    tcRnSrcDecls False local_decls
 
 externaliseAndTidyId :: Module -> Id -> TcM Id
 externaliseAndTidyId this_mod id
diff --git a/testsuite/tests/warnings/should_compile/T10908.hs b/testsuite/tests/warnings/should_compile/T10908.hs
new file mode 100644 (file)
index 0000000..a9af541
--- /dev/null
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-}
+
+module Bug (Data.List.intercalate, x) where
+
+import qualified Data.List
+
+intercalate = True
+
+x :: Bool
+x = intercalate
index c2b8dd2..f60468e 100644 (file)
@@ -4,6 +4,7 @@ test('T9178', extra_clean(['T9178.o', 'T9178DataType.o',
                           'T9178.hi', 'T9178DataType.hi']),
              multimod_compile, ['T9178', '-Wall'])
 test('T9230', normal, compile_without_flag('-fno-warn-tabs'), [''])
+test('T10908', normal, compile, [''])
 test('T11077', normal, compile, ['-fwarn-missing-exported-sigs'])
 test('T11128', normal, compile, [''])