Implement -fwarn-missing-pat-syn-sigs
authorMatthew Pickering <matthewtpickering@gmail.com>
Sat, 12 Dec 2015 16:38:07 +0000 (16:38 +0000)
committerMatthew Pickering <matthewtpickering@gmail.com>
Sat, 12 Dec 2015 16:39:36 +0000 (16:39 +0000)
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

compiler/hsSyn/HsBinds.hs
compiler/main/DynFlags.hs
compiler/rename/RnNames.hs
docs/users_guide/7.12.1-notes.rst
docs/users_guide/using-warnings.rst
libraries/base/GHC/Exception.hs
testsuite/tests/patsyn/should_compile/all.T
testsuite/tests/patsyn/should_fail/T11053.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/T11053.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/all.T

index cbd45d8..267627d 100644 (file)
@@ -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"
 
index 3dfd1ef..6487379 100644 (file)
@@ -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.
index 7d60d6e..18f2365 100644 (file)
@@ -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]
index 88196a5..ff24091 100644 (file)
@@ -114,23 +114,23 @@ Language
 
      -- Foo.hs
      module Foo where
-     
+
      data family T a
 
      -- Bar.hs
      module Bar where
-     
+
      import Foo
-     
+
      data instance T Int = MkT
 
      -- Baz.hs
      module Baz where
-     
+
      import Bar (T(MkT))
 
    In previous versions of GHC, this required a workaround via an
-   explicit export list in Bar. 
+   explicit export list in Bar.
 
 
 
@@ -193,6 +193,10 @@ Compiler
    warnings makes sure the definition of ``Semigroup`` as a superclass of
    ``Monoid`` does not break any code.
 
+- Added the ``-fwarn-missing-pat-syn-sigs`` flag. When enabled, this will issue
+  a warning when a pattern synonym definition doesn't have a type signature.
+  It is turned off by default but enabled by ``-Wall``.
+
 GHCi
 ~~~~
 
index b79ae8a..9b98686 100644 (file)
@@ -632,6 +632,17 @@ command line.
     about any polymorphic local bindings. As part of the warning GHC
     also reports the inferred type. The option is off by default.
 
+``-fwarn-missing-pat-syn-sigs``
+  .. index ::
+       single: -fwarn-missing-pat-syn-sigs
+       single: type signatures, missing, pattern synonyms
+
+  If you would like GHC to check that every pattern synonym has a type
+  signature, use the ``-fwarn-missing-pat-syn-sigs`` option. If this option is
+  used in conjunction with ``-fwarn-missing-exported-sigs`` then only
+  exported pattern synonyms must have a type signature. GHC also reports the
+  inferred type. This option is off by default.
+
 ``-fwarn-name-shadowing``
     .. index::
        single: -fwarn-name-shadowing
index e4925c7..afd1a50 100644 (file)
@@ -170,6 +170,7 @@ throw e = raise# (toException e)
 data ErrorCall = ErrorCallWithLocation String String
     deriving (Eq, Ord)
 
+pattern ErrorCall :: String -> ErrorCall
 pattern ErrorCall err <- ErrorCallWithLocation err _ where
   ErrorCall err = ErrorCallWithLocation err ""
 
index b35fd38..d89cab6 100644 (file)
@@ -42,5 +42,3 @@ test('poly-export3', normal, compile, [''])
 test('multi-export', normal, compile, [''])
 test('export-super-class', normal, compile, [''])
 test('export-record-selector', normal, compile, [''])
-
-
diff --git a/testsuite/tests/patsyn/should_fail/T11053.hs b/testsuite/tests/patsyn/should_fail/T11053.hs
new file mode 100644 (file)
index 0000000..33dec45
--- /dev/null
@@ -0,0 +1,18 @@
+{-# LANGUAGE PatternSynonyms #-}
+-- turn on with -fwarn-missing-pat-syn-sigs
+
+module Foo where
+
+-- Should warn because of missing signature
+pattern T = True
+
+pattern J a = Just a
+
+pattern J1 a <- Just a
+
+pattern J2{b} = Just b
+
+pattern J3{c} <- Just c
+
+pattern F :: Bool
+pattern F = False
diff --git a/testsuite/tests/patsyn/should_fail/T11053.stderr b/testsuite/tests/patsyn/should_fail/T11053.stderr
new file mode 100644 (file)
index 0000000..8bc6563
--- /dev/null
@@ -0,0 +1,19 @@
+
+T11053.hs:7:1: warning:
+    Top-level binding with no type signature: T :: Bool
+
+T11053.hs:9:1: warning:
+    Top-level binding with no type signature:
+      J :: forall t. t -> Maybe t
+
+T11053.hs:11:1: warning:
+    Top-level binding with no type signature:
+      J1 :: forall t. t -> Maybe t
+
+T11053.hs:13:1: warning:
+    Top-level binding with no type signature:
+      J2 :: forall t. t -> Maybe t
+
+T11053.hs:15:1: warning:
+    Top-level binding with no type signature:
+      J3 :: forall t. t -> Maybe t
index d5ebca9..26c68ca 100644 (file)
@@ -25,3 +25,4 @@ test('poly-export-fail2', expect_broken(10653), compile_fail, [''])
 test('export-super-class-fail', expect_broken(10653), compile_fail, [''])
 test('export-type-synonym', normal, compile_fail, [''])
 test('export-ps-rec-sel', normal, compile_fail, [''])
+test('T11053', normal, compile, ['-fwarn-missing-pat-syn-sigs'])