Commit 1883afb2 authored by Matthew Pickering's avatar Matthew Pickering

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
parent a3c2a26b
......@@ -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"
......
......@@ -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.
......
......@@ -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]
......
......@@ -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
~~~~
......
......@@ -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
......
......@@ -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 ""
......
......@@ -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, [''])
{-# 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
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
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment