Implement -fwarn-missing-pat-syn-sigs

This adds a warning when a pattern synonym is not accompanied by a
signature in the style of `-fwarn-missing-sigs`.

It is turned on by -Wall.

If the user specifies, `-fwarn-missing-exported-signatures` with
`-fwarn-missing-pat-syn-sigs` then it will only warn when the pattern
synonym is exported.

Test Plan: ./validate

Reviewers: hvr, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

GHC Trac Issues: #11053

3 files changed, 50 insertions, 20 deletions

diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index cbd45d8edb..267627d771 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -40,7 +40,8 @@ import FastString
 import BooleanFormula (LBooleanFormula)
 
 import Data.Data hiding ( Fixity )
-import Data.List
+import Data.List hiding ( foldr )
+import qualified Data.List as L (foldr)
 import Data.Ord
 import Data.Foldable ( Foldable(..) )
 #if __GLASGOW_HASKELL__ < 709
@@ -485,7 +486,15 @@ plusHsValBinds _ _
 getTypeSigNames :: HsValBinds a -> NameSet
 -- Get the names that have a user type sig
 getTypeSigNames (ValBindsOut _ sigs)
-  = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names]
+  = L.foldr get_type_sig emptyNameSet sigs
+  where
+    get_type_sig :: LSig Name -> NameSet -> NameSet
+    get_type_sig sig ns =
+      case sig of
+        L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
+        L _ (PatSynSig name _) -> extendNameSet ns (unLoc name)
+        _ -> ns
+
 getTypeSigNames _
   = panic "HsBinds.getTypeSigNames"
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3dfd1ef660..6487379726 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -537,6 +537,7 @@ data WarningFlag =
    | Opt_WarnDeferredTypeErrors
    | Opt_WarnNonCanonicalMonadInstances   -- since 8.0
    | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0
+   | Opt_WarnMissingPatSynSigs            -- since 8.0
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -2954,7 +2955,8 @@ fWarningFlags = [
   flagSpec "warn-unused-pattern-binds"        Opt_WarnUnusedPatternBinds,
   flagSpec "warn-unused-top-binds"            Opt_WarnUnusedTopBinds,
   flagSpec "warn-warnings-deprecations"       Opt_WarnWarningsDeprecations,
-  flagSpec "warn-wrong-do-bind"               Opt_WarnWrongDoBind]
+  flagSpec "warn-wrong-do-bind"               Opt_WarnWrongDoBind,
+  flagSpec "warn-missing-pat-syn-sigs"        Opt_WarnMissingPatSynSigs]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
 negatableFlags :: [FlagSpec GeneralFlag]
@@ -3499,7 +3501,8 @@ minusWallOpts
         Opt_WarnOrphans,
         Opt_WarnUnusedDoBind,
         Opt_WarnTrustworthySafe,
-        Opt_WarnUntickedPromotedConstructors
+        Opt_WarnUntickedPromotedConstructors,
+        Opt_WarnMissingPatSynSigs
       ]
 
 -- | Things you get with -Wcompat.
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 7d60d6e32a..18f2365c92 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -45,6 +45,7 @@ import FastStringEnv
 import ListSetOps
 import Id
 import Type
+import PatSyn
 
 import Control.Monad
 import Data.Either      ( partitionEithers, isRight, rights )
@@ -1557,20 +1558,31 @@ warnMissingSigs 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
 
          -- 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
+       ; warn_pat_syns      <- woptM Opt_WarnMissingPatSynSigs
 
        ; let sig_warn
                | warn_only_exported = topSigWarnIfExported exports sig_ns
-               | warn_missing_sigs  = topSigWarn sig_ns
+               | warn_missing_sigs || warn_pat_syns = topSigWarn sig_ns
                | otherwise          = noSigWarn
 
-       ; sig_warn (collectHsBindsBinders binds) }
 
-type SigWarn = [Id] -> RnM ()
+       ; 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
@@ -1580,34 +1592,40 @@ 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
+topSigWarnIdIfExported :: NameSet -> NameSet -> (Type, Name) -> RnM ()
+topSigWarnIdIfExported exported sig_ns (ty, name)
+  | name `elemNameSet` exported
+  = topSigWarnId sig_ns (ty, name)
   | otherwise
   = return ()
 
 topSigWarn :: NameSet -> SigWarn
 topSigWarn sig_ns ids = mapM_ (topSigWarnId sig_ns) ids
 
-topSigWarnId :: NameSet -> Id -> RnM ()
+topSigWarnId :: 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 sig_ns id
-  | idName id `elemNameSet` sig_ns = warnMissingSig msg id
+topSigWarnId sig_ns (ty, name)
+  | name `elemNameSet` sig_ns      = warnMissingSig msg (ty, name)
   | 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) }
+warnMissingSig :: SDoc -> (Type, Name) -> RnM ()
+warnMissingSig msg (ty, name) = do
+    tymsg <- getMsg ty
+    addWarnAt (getSrcSpan name) (mk_msg tymsg)
   where
-    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
+    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)
+       }
 
 {-
 Note [The ImportMap]