Improve printing of pattern synonym types
[ghc.git] / compiler / rename / RnNames.hs
index c9f916a..1659191 100644 (file)
@@ -1567,9 +1567,10 @@ warnUnusedImportDecls gbl_env
 warnMissingSignatures :: TcGblEnv -> RnM ()
 warnMissingSignatures gbl_env
   = do { let exports = availsToNameSet (tcg_exports gbl_env)
-             sig_ns = tcg_sigs gbl_env
-             all_binds = collectHsBindsBinders $ tcg_binds gbl_env
-             all_ps    = tcg_patsyns gbl_env
+             sig_ns  = tcg_sigs gbl_env
+               -- We use sig_ns to exclude top-level bindings that are generated by GHC
+             binds    = collectHsBindsBinders $ tcg_binds gbl_env
+             pat_syns = tcg_patsyns gbl_env
 
          -- Warn about missing signatures
          -- Do this only when we we have a type to offer
@@ -1584,27 +1585,32 @@ warnMissingSignatures gbl_env
                | 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 ]
+                = when warn_pat_syns
+                       (mapM_ add_pat_syn_warn pat_syns) >>
+                  when (warn_missing_sigs || warn_only_exported)
+                       (mapM_ add_bind_warn binds)
+                where
+                  add_pat_syn_warn p
+                    = add_warn (patSynName p) (pprPatSynType p)
+
+                  add_bind_warn id
+                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?
+                         ; let name    = idName id
+                               (_, ty) = tidyOpenType env (idType id)
+                               ty_msg  = ppr ty
+                         ; add_warn name ty_msg }
+
+                  add_warn name ty_msg
+                    = when (name `elemNameSet` sig_ns && export_check name)
+                           (addWarnAt (Reason flag) (getSrcSpan name)
+                                                    (get_msg name ty_msg))
+
+                  export_check name
+                    = not warn_only_exported || name `elemNameSet` exports
+
+                  get_msg name ty_msg
+                    = sep [ text "Top-level binding with no type signature:",
+                            nest 2 $ pprPrefixName name <+> dcolon <+> ty_msg ]
 
        ; add_sig_warns }