[commit: ghc] master: Refactor `warnMissingSignatures` in `RnNames.hs` (f72bdbd)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f72bdbd2fd4204975eb8699cacc4310090134a9f/ghc

>---------------------------------------------------------------

commit f72bdbd2fd4204975eb8699cacc4310090134a9f
Author: Rik Steenkamp <rik at ewps.nl>
Date:   Mon Feb 29 11:56:16 2016 +0100

    Refactor `warnMissingSignatures` in `RnNames.hs`
    
    Reviewers: austin, thomie, bgamari
    
    Reviewed By: thomie, bgamari
    
    Differential Revision: https://phabricator.haskell.org/D1955


>---------------------------------------------------------------

f72bdbd2fd4204975eb8699cacc4310090134a9f
 compiler/rename/RnNames.hs | 101 ++++++++++++++-------------------------------
 1 file changed, 32 insertions(+), 69 deletions(-)

diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 70f76b9..c9f916a 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -1568,8 +1568,8 @@ warnMissingSignatures :: TcGblEnv -> RnM ()
 warnMissingSignatures gbl_env
   = do { let exports = availsToNameSet (tcg_exports gbl_env)
              sig_ns = tcg_sigs gbl_env
-             binds = tcg_binds gbl_env
-             ps    = tcg_patsyns gbl_env
+             all_binds = collectHsBindsBinders $ tcg_binds gbl_env
+             all_ps    = tcg_patsyns gbl_env
 
          -- Warn about missing signatures
          -- Do this only when we we have a type to offer
@@ -1577,73 +1577,36 @@ warnMissingSignatures gbl_env
        ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures
        ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures
 
-       ; let sig_warn
-               | warn_only_exported
-                   = topSigWarnIfExported Opt_WarnMissingExportedSignatures
-                                          exports sig_ns
-               | warn_missing_sigs
-                   = topSigWarn Opt_WarnMissingSignatures sig_ns
-               | warn_pat_syns
-                   = topSigWarn Opt_WarnMissingPatternSynonymSignatures sig_ns
-               | otherwise
-                   = noSigWarn
-
-
-       ; let binders = (if warn_pat_syns then ps_binders else [])
-                        ++ (if warn_missing_sigs || warn_only_exported
-                              then fun_binders else [])
-
-             fun_binders = [(idType b, idName b)| b
-                              <- collectHsBindsBinders binds]
-             ps_binders  = [(patSynType p, patSynName p) | p <- ps]
-
-       ; sig_warn binders }
-
-type SigWarn = [(Type, Name)] -> RnM ()
-     -- Missing-signature warning
-
-noSigWarn :: SigWarn
-noSigWarn _ = return ()
-
-topSigWarnIfExported :: WarningFlag -> NameSet -> NameSet -> SigWarn
-topSigWarnIfExported flag exported sig_ns ids
-  = mapM_ (topSigWarnIdIfExported flag exported sig_ns) ids
-
-topSigWarnIdIfExported :: WarningFlag -> NameSet -> NameSet -> (Type, Name)
-                       -> RnM ()
-topSigWarnIdIfExported flag exported sig_ns (ty, name)
-  | name `elemNameSet` exported
-  = topSigWarnId flag sig_ns (ty, name)
-  | otherwise
-  = return ()
-
-topSigWarn :: WarningFlag -> NameSet -> SigWarn
-topSigWarn flag sig_ns ids = mapM_ (topSigWarnId flag sig_ns) ids
-
-topSigWarnId :: WarningFlag -> NameSet -> (Type, Name) -> 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 flag sig_ns (ty, name)
-  | name `elemNameSet` sig_ns      = warnMissingSig flag msg (ty, name)
-  | otherwise                      = return ()
-  where
-    msg = text "Top-level binding with no type signature:"
-
-warnMissingSig :: WarningFlag -> SDoc -> (Type, Name) -> RnM ()
-warnMissingSig flag msg (ty, name) = do
-    tymsg <- getMsg ty
-    addWarnAt (Reason flag) (getSrcSpan name) (mk_msg tymsg)
-  where
-    mk_msg endmsg = sep [ msg, nest 2 $ pprPrefixName name <+> endmsg ]
-
-    getMsg :: Type -> RnM SDoc
-    getMsg ty = do
-       { env <- tcInitTidyEnv
-       ; let (_, tidy_ty) = tidyOpenType env ty
-       ; return (dcolon <+> ppr tidy_ty)
-       }
+       ; let add_sig_warns
+               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures
+               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures
+               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures
+               | otherwise          = return ()
+
+             add_warns flag
+               = forM_ binders
+                 (\(name, ty) ->
+                    do { env <- tcInitTidyEnv
+                       ; let (_, tidy_ty) = tidyOpenType env ty
+                       ; addWarnAt (Reason flag) (getSrcSpan name)
+                                                 (get_msg name tidy_ty) })
+
+             binds   = if warn_missing_sigs || warn_only_exported then all_binds else []
+             ps      = if warn_pat_syns                           then all_ps    else []
+             binders = filter pred $
+                         [(patSynName p, patSynType p) | p <- ps   ] ++
+                         [(idName b, idType b)         | b <- binds]
+
+             pred (name, _) = name `elemNameSet` sig_ns
+                              && (not warn_only_exported || name `elemNameSet` exports)
+               -- We use sig_ns to exclude top-level bindings that are
+               -- generated by GHC and that don't have signatures
+
+             get_msg name ty
+               = sep [ text "Top-level binding with no type signature:",
+                       nest 2 $ pprPrefixName name <+> dcolon <+> ppr ty ]
+
+       ; add_sig_warns }
 
 {-
 Note [The ImportMap]