Refactor wild card renaming

Summary:
Refactor wild card error reporting

* Merge `HsWildcardTy` and `HsNamedWildcardTy` into one constructor
  `HsWildCardTy` with as field the new type `HsWildCardInfo`, which has two
  constructors: `AnonWildCard` and `NamedWildCard`.

* All partial type checks are removed from `RdrHsSyn.hs` and are now done
  during renaming in order to report better error messages. When wild cards
  are allowed in a type, the new function `rnLHsTypeWithWildCards` (or
  `rnHsSigTypeWithWildCards`) should be used. This will bring the named wild
  cards into scope before renaming them. When this is not done, renaming will
  trigger "Unexpected wild card..." errors.

  Unfortunately, this has to be done separately for anonymous wild cards
  because they are given a fresh name during renaming, so they will not cause
  an out-of-scope error. They are handled in `tc_hs_type`, as a special case
  of a lookup that fails.

  The previous opt-out approach is replaced with an opt-in approach. No more
  panics because of forgotten checks!

* `[t| _ |]` isn't caught by the above two checks, so it is currently handled
  by a special case. The error message (generated in the `DsM` monad) doesn't
  provide as much context information as the other cases.

* Instead of three (!) functions that walk `HsType`, there is now only one
  pure function called `collectWildCards`.

* Alternative approach: catch all unwanted wild cards in `rnHsTyKi` by looking
  at the `HsDocContext`. This will reduce the number of places to catch
  unwanted wild cards form three to one, and make the error messages more
  uniform, albeit less informative, as the error context for renaming is not
  as informative as the one for type checking. A new constructor of
  `HsDocContext` will be required for pattern synonyms signatures.

  Small problem: currently type-class type signatures can't be distinguished
  from type signatures using the `HsDocContext`.

This requires an update to the Haddock submodule.

Test Plan: validate

Reviewers: goldfire, simonpj, austin

Reviewed By: simonpj

Subscribers: bgamari, thomie, goldfire

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

GHC Trac Issues: #10098

12 files changed, 279 insertions, 420 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 010af3c833..70bc6908f7 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -909,7 +909,12 @@ repTy (HsExplicitTupleTy _ tys) = do
 repTy (HsTyLit lit) = do
                         lit' <- repTyLit lit
                         repTLit lit'
-                          
+repTy (HsWildCardTy wc) = do
+                            let name = HsSyn.wildCardName wc
+                            putSrcSpanDs (nameSrcSpan name) $
+                              failWithDs $ text "Unexpected wild card:" <+>
+                                           quotes (ppr name)
+
 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
 
 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 09c4a2f991..9b8639369c 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -33,6 +33,9 @@ module HsTypes (
 
         ConDeclField(..), LConDeclField, pprConDeclFields,
 
+        HsWildCardInfo(..), mkAnonWildCardTy, mkNamedWildCardTy,
+        wildCardName, sameWildCard, isAnonWildCard, isNamedWildCard,
+
         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
         mkHsForAllTy,
@@ -45,7 +48,7 @@ module HsTypes (
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
-        isWildcardTy, isNamedWildcardTy,
+        ignoreParens,
 
         -- Printing
         pprParendHsType, pprHsForAll, pprHsForAllExtra,
@@ -179,7 +182,7 @@ data HsWithBndrs name thing
   = HsWB { hswb_cts :: thing             -- Main payload (type or list of types)
          , hswb_kvs :: PostRn name [Name] -- Kind vars
          , hswb_tvs :: PostRn name [Name] -- Type vars
-         , hswb_wcs :: PostRn name [Name] -- Wildcards
+         , hswb_wcs :: PostRn name [Name] -- Wild cards
     }
   deriving (Typeable)
 deriving instance (Data name, Data thing, Data (PostRn name [Name]))
@@ -387,12 +390,7 @@ data HsType name
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsWildcardTy           -- A type wildcard
-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
-
-      -- For details on above see note [Api annotations] in ApiAnnotation
-
-  | HsNamedWildcardTy name -- A named wildcard
+  | HsWildCardTy (HsWildCardInfo name)  -- A type wildcard
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
@@ -416,6 +414,14 @@ type HsTyOp name = (HsTyWrapper, name)
 mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
 mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
 
+data HsWildCardInfo name
+    = AnonWildCard (PostRn name Name)
+      -- A anonymous wild card ('_'). A name is generated during renaming.
+    | NamedWildCard name
+      -- A named wild card ('_a').
+    deriving (Typeable)
+deriving instance (DataId name) => Data (HsWildCardInfo name)
+
 {-
 Note [HsForAllTy tyvar binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -568,17 +574,8 @@ mkQualifiedHsForAllTy     ctxt ty = mkHsForAllTy Qualified []  ctxt ty
 -- |Smart constructor for HsForAllTy, which populates the extra-constraints
 -- field if a wildcard is present in the context.
 mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
-mkHsForAllTy exp tvs (L l []) ty
-  = HsForAllTy exp Nothing (mkHsQTvs tvs) (L l []) ty
-mkHsForAllTy exp tvs ctxt     ty
-  = HsForAllTy exp extra   (mkHsQTvs tvs) cleanCtxt        ty
-  where -- Separate the extra-constraints wildcard when present
-        (cleanCtxt, extra)
-          | (L l HsWildcardTy) <- ignoreParens (last (unLoc ctxt)) = (init `fmap` ctxt, Just l)
-          | otherwise = (ctxt, Nothing)
-        ignoreParens (L _ (HsParTy ty)) = ty
-        ignoreParens ty                 = ty
-
+mkHsForAllTy exp tvs ctxt ty
+  = HsForAllTy exp Nothing (mkHsQTvs tvs) ctxt ty
 
 -- |When a sigtype is parsed, the type found is wrapped in an Implicit
 -- HsForAllTy via mkImplicitHsForAllTy, to ensure that a signature always has a
@@ -659,13 +656,31 @@ hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
 hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
 
 ---------------------
-isWildcardTy :: HsType a -> Bool
-isWildcardTy HsWildcardTy = True
-isWildcardTy _ = False
+mkAnonWildCardTy :: HsType RdrName
+mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)
 
-isNamedWildcardTy :: HsType a -> Bool
-isNamedWildcardTy (HsNamedWildcardTy _) = True
-isNamedWildcardTy _ = False
+mkNamedWildCardTy :: n -> HsType n
+mkNamedWildCardTy = HsWildCardTy . NamedWildCard
+
+isAnonWildCard :: HsWildCardInfo name -> Bool
+isAnonWildCard (AnonWildCard _) = True
+isAnonWildCard _                = False
+
+isNamedWildCard :: HsWildCardInfo name -> Bool
+isNamedWildCard = not . isAnonWildCard
+
+wildCardName :: HsWildCardInfo Name -> Name
+wildCardName (NamedWildCard n) = n
+wildCardName (AnonWildCard  n) = n
+
+-- Two wild cards are the same when: they're both named and have the same
+-- name, or they're both anonymous and have the same location.
+sameWildCard :: Eq name
+             => Located (HsWildCardInfo name)
+             -> Located (HsWildCardInfo name) -> Bool
+sameWildCard (L l1 (AnonWildCard _))   (L l2 (AnonWildCard _))   = l1 == l2
+sameWildCard (L _  (NamedWildCard n1)) (L _  (NamedWildCard n2)) = n1 == n2
+sameWildCard _ _ = False
 
 splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
 splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
@@ -761,6 +776,10 @@ splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
 
 splitHsFunType other = ([], other)
 
+ignoreParens :: LHsType name -> LHsType name
+ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
+ignoreParens ty                 = ty
+
 {-
 ************************************************************************
 *                                                                      *
@@ -786,6 +805,10 @@ instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
 instance (Outputable thing) => Outputable (HsWithBndrs name thing) where
     ppr (HsWB { hswb_cts = ty }) = ppr ty
 
+instance (Outputable name) => Outputable (HsWildCardInfo name) where
+    ppr (AnonWildCard _)  = char '_'
+    ppr (NamedWildCard n) = ppr n
+
 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc
 pprHsForAll exp = pprHsForAllExtra exp Nothing
 
@@ -889,8 +912,8 @@ ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 ppr_mono_ty _    (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
 ppr_mono_ty _    (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
 ppr_mono_ty _    (HsTyLit t)         = ppr_tylit t
-ppr_mono_ty _    HsWildcardTy        = char '_'
-ppr_mono_ty _    (HsNamedWildcardTy name) = ppr name
+ppr_mono_ty _    (HsWildCardTy (AnonWildCard _))     = char '_'
+ppr_mono_ty _    (HsWildCardTy (NamedWildCard name)) = ppr name
 
 ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
   = ppr_mono_ty ctxt_prec ty
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index 246abc02f5..00a2cdf5d6 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -97,6 +97,7 @@ type DataId id =
   , Data (PostRn id NameSet)
   , Data (PostRn id Fixity)
   , Data (PostRn id Bool)
+  , Data (PostRn id Name)
   , Data (PostRn id [Name])
 
   , Data (PostTc id Type)
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 2739e10fb2..b88a3b1bf8 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -841,10 +841,9 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | inst_decl                             { unitOL (sL1 $1 (InstD (unLoc $1))) }
         | stand_alone_deriving                  { unitOL (sLL $1 $> (DerivD (unLoc $1))) }
         | role_annot                            { unitOL (sL1 $1 (RoleAnnotD (unLoc $1))) }
-        | 'default' '(' comma_types0 ')'    {% do { def <- checkValidDefaults $3
-                                                  ; amsu (sLL $1 $> (DefD def))
+        | 'default' '(' comma_types0 ')'    {% amsu (sLL $1 $> (DefD (DefaultDecl $3)))
                                                          [mj AnnDefault $1
-                                                         ,mop $2,mcp $4] }}
+                                                         ,mop $2,mcp $4] }
         | 'foreign' fdecl          {% amsu (sLL $1 $> (snd $ unLoc $2))
                                            (mj AnnForeign $1:(fst $ unLoc $2)) }
         | '{-# DEPRECATED' deprecations '#-}'   {% amsu (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2)))
@@ -950,12 +949,6 @@ inst_decl :: { LInstDecl RdrName }
                                      , cid_sigs = sigs, cid_tyfam_insts = ats
                                      , cid_overlap_mode = $2
                                      , cid_datafam_insts = adts }
-             ; let err = text "In instance head:" <+> ppr $3
-             ; checkNoPartialType err $3
-             ; sequence_ [ checkNoPartialType err ty
-                         | sig@(L _ (TypeSig _ ty _ )) <- sigs
-                         , let err = text "in instance signature" <> colon
-                                     <+> quotes (ppr sig) ]
              ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }))
                    (mj AnnInstance $1 : (fst $ unLoc $4)) } }
 
@@ -1138,7 +1131,6 @@ stand_alone_deriving :: { LDerivDecl RdrName }
                          {% do {
                                  let err = text "in the stand-alone deriving instance"
                                             <> colon <+> quotes (ppr $4)
-                               ; checkNoPartialType err $4
                                ; ams (sLL $1 $> (DerivDecl $4 $3))
                                      [mj AnnDeriving $1,mj AnnInstance $2] }}
 
@@ -1204,7 +1196,6 @@ pattern_synonym_sig :: { LSig RdrName }
         : 'pattern' con '::' ptype
             {% do { let (flag, qtvs, prov, req, ty) = snd $ unLoc $4
                   ; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty
-                  ; checkValidPatSynSig sig
                   ; ams (sLL $1 $> $ sig)
                         (mj AnnPattern $1:mj AnnDcolon $3:(fst $ unLoc $4)) } }
 
@@ -1239,7 +1230,6 @@ decl_cls  : at_decl_cls                 { sLL $1 $> (unitOL $1) }
                     {% do { (TypeSig l ty _) <- checkValSig $2 $4
                           ; let err = text "in default signature" <> colon <+>
                                       quotes (ppr ty)
-                          ; checkNoPartialType err ty
                           ; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty)))
                                 [mj AnnDefault $1,mj AnnDcolon $3] } }
 
@@ -1657,10 +1647,10 @@ btype :: { LHsType RdrName }
 
 atype :: { LHsType RdrName }
         : ntgtycon                       { sL1 $1 (HsTyVar (unLoc $1)) }      -- Not including unit tuples
-        | tyvar                          {% do { nwc <- namedWildcardsEnabled -- (See Note [Unit tuples])
+        | tyvar                          {% do { nwc <- namedWildCardsEnabled -- (See Note [Unit tuples])
                                                ; let tv@(Unqual name) = unLoc $1
                                                ; return $ if (startsWithUnderscore name && nwc)
-                                                          then (sL1 $1 (HsNamedWildcardTy tv))
+                                                          then (sL1 $1 (mkNamedWildCardTy tv))
                                                           else (sL1 $1 (HsTyVar tv)) } }
 
         | strict_mark atype              {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
@@ -1717,7 +1707,7 @@ atype :: { LHsType RdrName }
                                                                (getINTEGER $1) }
         | STRING               { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)
                                                                (getSTRING  $1) }
-        | '_'                  { sL1 $1 $ HsWildcardTy }
+        | '_'                  { sL1 $1 $ mkAnonWildCardTy }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
@@ -2039,14 +2029,12 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
           infixexp '::' sigtypedoc
-                        {% do ty <- checkPartialTypeSignature $3
-                        ; s <- checkValSig $1 ty
+                        {% do s <- checkValSig $1 $3
                         ; _ <- ams (sLL $1 $> ()) [mj AnnDcolon $2]
                         ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) }
 
         | var ',' sig_vars '::' sigtypedoc
-           {% do { ty <- checkPartialTypeSignature $5
-                 ; let sig = TypeSig ($1 : reverse (unLoc $3)) ty PlaceHolder
+           {% do { let sig = TypeSig ($1 : reverse (unLoc $3)) $5 PlaceHolder
                  ; addAnnotation (gl $1) AnnComma (gl $2)
                  ; ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD sig ])
                        [mj AnnDcolon $4] } }
@@ -2318,10 +2306,7 @@ aexp2   :: { LHsExpr RdrName }
         | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
         | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) [mo $1,mc $3] }
         | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]}
-        | '[t|' ctype '|]'    {% checkNoPartialType
-                                   (text "in type brackets" <> colon
-                                    <+> quotes (text "[t|" <+> ppr $2 <+> text "|]")) $2 >>
-                                 ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mc $3] }
+        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mc $3] }
         | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
                                       ams (sLL $1 $> $ HsBracket (PatBr p))
                                           [mo $1,mc $3] }
@@ -3301,8 +3286,8 @@ hintExplicitForall span = do
       , text "extension to enable explicit-forall syntax: \x2200 <tvs>. <type>"
       ]
 
-namedWildcardsEnabled :: P Bool
-namedWildcardsEnabled = liftM ((Opt_NamedWildCards `xopt`) . dflags) getPState
+namedWildCardsEnabled :: P Bool
+namedWildCardsEnabled = liftM ((Opt_NamedWildCards `xopt`) . dflags) getPState
 
 {-
 %************************************************************************
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 98fa8f7608..d7af65da8e 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -49,12 +49,8 @@ module RdrHsSyn (
         checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-        checkPartialTypeSignature,
-        checkNoPartialType,
-        checkValidPatSynSig,
         checkDoAndIfThenElse,
         checkRecordSyntax,
-        checkValidDefaults,
         parseErrorSDoc,
 
         -- Help with processing exports
@@ -101,8 +97,6 @@ import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
 
 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
-import Data.List       ( partition )
-import qualified Data.Set as Set ( fromList, difference, member )
 
 #include "HsVersions.h"
 
@@ -140,8 +134,6 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams,ann) <- checkTyClHdr True tycl_hdr
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
-       -- Partial type signatures are not allowed in a class definition
-       ; checkNoPartialSigs sigs cls
        ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
@@ -165,104 +157,6 @@ mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
                                      , tfe_pats = tvs
                                      , tfe_rhs = rhs })) }
 
--- | Check that none of the given type signatures of the class definition
--- ('Located RdrName') are partial type signatures. An error will be reported
--- for each wildcard found in a (partial) type signature. We do this check
--- because we want the signatures in a class definition to be fully specified.
-checkNoPartialSigs :: [LSig RdrName] -> Located RdrName -> P ()
-checkNoPartialSigs sigs cls_name =
-  sequence_ [ whenIsJust mb_loc $ \loc -> parseErrorSDoc loc $ err sig
-            | L _ sig@(TypeSig _ ty _) <- sigs
-            , let mb_loc = maybeLocation $ findWildcards ty ]
-  where err sig =
-          vcat [ text "The type signature of a class method cannot be partial:"
-               , ppr sig
-               , text "In the class declaration for " <> quotes (ppr cls_name) ]
-
--- | Check that none of the given constructors contain a wildcard (like in a
--- partial type signature). An error will be reported for each wildcard found
--- in a (partial) constructor definition. We do this check because we want the
--- type of a constructor to be fully specified.
-checkNoPartialCon :: [LConDecl RdrName] -> P ()
-checkNoPartialCon con_decls =
-  sequence_ [ whenIsJust mb_loc $ \loc -> parseErrorSDoc loc $ err cd
-            | L _ cd@(ConDecl { con_cxt = cxt, con_res = res,
-                                con_details = details }) <- con_decls
-            , let mb_loc = maybeLocation $
-                           concatMap findWildcards (unLoc cxt) ++
-                           containsWildcardRes res ++
-                           concatMap findWildcards
-                           (hsConDeclArgTys details) ]
-  where err con_decl = text "A constructor cannot have a partial type:" $$
-                       ppr con_decl
-        containsWildcardRes (ResTyGADT _ ty) = findWildcards ty
-        containsWildcardRes ResTyH98 = notFound
-
--- | Check that the given type does not contain wildcards, and is thus not a
--- partial type. If it contains wildcards, report an error with the given
--- message.
-checkNoPartialType :: SDoc -> LHsType RdrName -> P ()
-checkNoPartialType context_msg ty =
-  whenFound (findWildcards ty) $ \loc -> parseErrorSDoc loc err
-  where err = text "Wildcard not allowed" $$ context_msg
-
--- | Represent wildcards found in a type. Used for reporting errors for types
--- that mustn't contain wildcards.
-data FoundWildcard = Found      { location :: SrcSpan }
-                   | FoundNamed { location :: SrcSpan, _name :: RdrName }
-
--- | Indicate that no wildcards were found.
-notFound :: [FoundWildcard]
-notFound = []
-
--- | Call the function (second argument), accepting the location of the
--- wildcard, on the first wildcard that was found, if any.
-whenFound :: [FoundWildcard] -> (SrcSpan -> P ()) -> P ()
-whenFound (Found loc:_)        f = f loc
-whenFound (FoundNamed loc _:_) f = f loc
-whenFound _                    _ = return ()
-
--- | Extract the location of the first wildcard, if any.
-maybeLocation :: [FoundWildcard] -> Maybe SrcSpan
-maybeLocation fws = location <$> listToMaybe fws
-
--- | Extract the named wildcards from the wildcards that were found.
-namedWildcards :: [FoundWildcard] -> [RdrName]
-namedWildcards fws = [name | FoundNamed _ name <- fws]
-
--- | Split the found wildcards into a list of found unnamed wildcard and found
--- named wildcards.
-splitUnnamedNamed :: [FoundWildcard] -> ([FoundWildcard], [FoundWildcard])
-splitUnnamedNamed = partition (\f -> case f of { Found _ -> True ; _ -> False})
-
--- | Return a list of the wildcards found while traversing the given type.
-findWildcards :: LHsType RdrName -> [FoundWildcard]
-findWildcards (L l ty) = case ty of
-    (HsForAllTy _ xtr _ (L _ ctxt) x) -> (map Found $ maybeToList xtr) ++
-                                         concatMap go ctxt ++ go x
-    (HsAppTy x y)            -> go x ++ go y
-    (HsFunTy x y)            -> go x ++ go y
-    (HsListTy x)             -> go x
-    (HsPArrTy x)             -> go x
-    (HsTupleTy _ xs)         -> concatMap go xs
-    (HsOpTy x _ y)           -> go x ++ go y
-    (HsParTy x)              -> go x
-    (HsIParamTy _ x)         -> go x
-    (HsEqTy x y)             -> go x ++ go y
-    (HsKindSig x y)          -> go x ++ go y
-    (HsDocTy x _)            -> go x
-    (HsBangTy _ x)           -> go x
-    (HsRecTy xs)             ->
-      concatMap (go . getBangType . cd_fld_type . unLoc) xs
-    (HsExplicitListTy _ xs)  -> concatMap go xs
-    (HsExplicitTupleTy _ xs) -> concatMap go xs
-    (HsWrapTy _ x)           -> go (noLoc x)
-    HsWildcardTy             -> [Found l]
-    (HsNamedWildcardTy n)    -> [FoundNamed l n]
-    -- HsTyVar, HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
-    _                        -> notFound
-  where go = findWildcards
-
 mkTyData :: SrcSpan
          -> NewOrData
          -> Maybe (Located CType)
@@ -289,17 +183,12 @@ mkDataDefn :: NewOrData
            -> P (HsDataDefn RdrName)
 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
-       ; checkNoPartialCon data_cons
-       ; whenIsJust maybe_deriv $
-         \(L _ deriv) -> mapM_ (checkNoPartialType (errDeriv deriv)) deriv
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                             , dd_ctxt = cxt
                             , dd_cons = data_cons
                             , dd_kindSig = ksig
                             , dd_derivs = maybe_deriv }) }
-    where errDeriv deriv = text "In the deriving items:" <+>
-                           pprHsContextNoArrow deriv
 
 
 mkTySynonym :: SrcSpan
@@ -310,9 +199,6 @@ mkTySynonym loc lhs rhs
   = do { (tc, tparams,ann) <- checkTyClHdr False lhs
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams
-       ; let err = text "In type synonym" <+> quotes (ppr tc) <>
-                   colon <+> ppr rhs
-       ; checkNoPartialType err rhs
        ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
                                 , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
 
@@ -320,12 +206,7 @@ mkTyFamInstEqn :: LHsType RdrName
                -> LHsType RdrName
                -> P (TyFamInstEqn RdrName,[AddAnn])
 mkTyFamInstEqn lhs rhs
-  = do { (tc, tparams,ann) <- checkTyClHdr False lhs
-       ; let err xhs = hang (text "In type family instance equation of" <+>
-                             quotes (ppr tc) <> colon)
-                       2 (ppr xhs)
-       ; checkNoPartialType (err lhs) lhs
-       ; checkNoPartialType (err rhs) rhs
+  = do { (tc, tparams, ann) <- checkTyClHdr False lhs
        ; return (TyFamEqn { tfe_tycon = tc
                           , tfe_pats  = mkHsWithBndrs tparams
                           , tfe_rhs   = rhs },
@@ -637,11 +518,7 @@ mkGadtDecl' :: [Located RdrName]
 -- and expand it as if it had been
 --    C :: ty; D :: ty
 -- (Just like type signatures in general.)
-mkGadtDecl' _ ty@(L _ (HsForAllTy _ (Just l) _ _ _))
-  = parseErrorSDoc l $
-    text "A constructor cannot have a partial type:" $$
-    ppr ty
-mkGadtDecl' names (L ls (HsForAllTy imp Nothing qvars cxt tau))
+mkGadtDecl' names (L ls (HsForAllTy imp _ qvars cxt tau))
   = return $ mk_gadt_con names
   where
     (details, res_ty)           -- See Note [Sorting out the result type]
@@ -822,8 +699,6 @@ checkDatatypeContext (Just (L loc c))
              parseErrorSDoc loc
                  (text "Illegal datatype context (use DatatypeContexts):" <+>
                   pprHsContext c)
-         mapM_ (checkNoPartialType err) c
-      where err = text "In the context:" <+> pprHsContextNoArrow c
 
 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
 checkRecordSyntax lr@(L loc r)
@@ -1096,144 +971,6 @@ checkValSig lhs@(L l _) ty
     default_RDR = mkUnqual varName (fsLit "default")
 
 
--- | Check that the default declarations do not contain wildcards in their
--- types, which we do not want as the types in the default declarations must
--- be fully specified.
-checkValidDefaults :: [LHsType RdrName] -> P (DefaultDecl RdrName)
-checkValidDefaults tys = mapM_ (checkNoPartialType err) tys >> return ret
-  where ret = DefaultDecl tys
-        err = text "In declaration:" <+> ppr ret
-
--- | Check that the pattern synonym type signature does not contain wildcards.
-checkValidPatSynSig :: Sig RdrName -> P (Sig RdrName)
-checkValidPatSynSig psig@(PatSynSig _ _ prov req ty)
-  = mapM_ (checkNoPartialType err) (unLoc prov ++ unLoc req ++ [ty])
-    >> return psig
-  where err = hang (text "In pattern synonym type signature: ")
-                   2 (ppr psig)
-checkValidPatSynSig sig = return sig
--- Should only be called with a pattern synonym type signature
-
--- | Check the validity of a partial type signature. We check the following
--- things:
---
--- * There should only be one extra-constraints wildcard in the type
--- signature, i.e. the @_@ in @_ => a -> String@.
--- This would be invalid: @(Eq a, _) => a -> (Num a, _) => a -> Bool@.
--- Extra-constraints wildcards are only allowed in the top-level context.
---
--- * Named extra-constraints wildcards aren't allowed,
--- e.g. invalid: @(Show a, _x) => a -> String@.
---
--- * There is only one extra-constraints wildcard in the context and it must
--- come last, e.g. invalid: @(_, Show a) => a -> String@
--- or @(_, Show a, _) => a -> String@.
---
--- * There should be no unnamed wildcards in the context.
---
--- * Named wildcards occurring in the context must also occur in the monotype.
---
--- An error is reported when an invalid wildcard is found.
-checkPartialTypeSignature :: LHsType RdrName -> P (LHsType RdrName)
-checkPartialTypeSignature fullTy = case fullTy of
-
-  (L l (HsForAllTy flag extra bndrs (L lc ctxtP) ty)) -> do
-    -- Remove parens around types in the context
-    let ctxt = map ignoreParens ctxtP
-    -- Check that the type doesn't contain any more extra-constraints wildcards
-    checkNoExtraConstraintsWildcard ty
-    -- Named extra-constraints wildcards aren't allowed
-    whenIsJust (firstMatch isNamedWildcardTy ctxt) $
-      \(L l _) -> err hintNamed l fullTy
-    -- There should be no more (extra-constraints) wildcards in the context.
-    -- If there was one at the end of the context, it is by now already
-    -- removed from the context and stored in the @extra@ field of the
-    -- 'HsForAllTy' by 'HsTypes.mkHsForAllTy'.
-    whenIsJust (firstMatch isWildcardTy ctxt) $
-      \(L l _) -> err hintLast l fullTy
-    -- Find all wildcards in the context and the monotype, then divide
-    -- them in unnamed and named wildcards
-    let (unnamedInCtxt, namedInCtxt) = splitUnnamedNamed $
-                                       concatMap findWildcards ctxt
-        (_            , namedInTy)   = splitUnnamedNamed $
-                                       findWildcards ty
-    -- Unnamed wildcards aren't allowed in the context
-    case unnamedInCtxt of
-      (Found lc : _) -> err hintUnnamedConstraint lc fullTy
-      _              -> return ()
-    -- Calculcate the set of named wildcards in the context that aren't in the
-    -- monotype (tau)
-    let namedWildcardsNotInTau = Set.fromList (namedWildcards namedInCtxt)
-                                 `Set.difference`
-                                 Set.fromList (namedWildcards namedInTy)
-    -- Search for the first named wildcard that we encountered in the
-    -- context that isn't present in the monotype (we lose the order
-    -- in which they occur when using the Set directly).
-    case filter (\(FoundNamed _ name) -> Set.member name namedWildcardsNotInTau)
-                namedInCtxt of
-      (FoundNamed lc name:_) -> err (hintNamedNotInMonotype name) lc fullTy
-      _                      -> return ()
-
-    -- Return the checked type
-    return $ L l (HsForAllTy flag extra bndrs (L lc ctxtP) ty)
-
-
-  ty -> do
-    checkNoExtraConstraintsWildcard ty
-    return ty
-
-  where
-    ignoreParens (L _ (HsParTy ty)) = ty
-    ignoreParens ty                 = ty
-
-    firstMatch :: (HsType a -> Bool) -> HsContext a -> Maybe (LHsType a)
-    firstMatch pred ctxt = listToMaybe (filter (pred . unLoc) ctxt)
-
-    err hintSDoc lc ty = parseErrorSDoc lc $
-                         text "Invalid partial type signature:" $$
-                         ppr ty $$ hintSDoc
-    hintLast    = sep [ text "An extra-constraints wildcard is only allowed"
-                      , text "at the end of the constraints" ]
-    hintNamed   = text "A named wildcard cannot occur as a constraint"
-    hintNested  = sep [ text "An extra-constraints wildcard is only allowed"
-                      , text "at the top-level of the signature" ]
-    hintUnnamedConstraint
-      = text "Wildcards are not allowed within the constraints"
-    hintNamedNotInMonotype name
-      = sep [ text "The named wildcard" <+> quotes (ppr name) <+>
-              text "is only allowed in the constraints"
-            , text "when it also occurs in the (mono)type" ]
-
-    checkNoExtraConstraintsWildcard (L _ ty) = go ty
-      where
-        -- Report nested (named) extra-constraints wildcards
-        go' = go . unLoc
-        go (HsAppTy x y)            = go' x >> go' y
-        go (HsFunTy x y)            = go' x >> go' y
-        go (HsListTy x)             = go' x
-        go (HsPArrTy x)             = go' x
-        go (HsTupleTy _ xs)         = mapM_ go' xs
-        go (HsOpTy x _ y)           = go' x >> go' y
-        go (HsParTy x)              = go' x
-        go (HsIParamTy _ x)         = go' x
-        go (HsEqTy x y)             = go' x >> go' y
-        go (HsKindSig x y)          = go' x >> go' y
-        go (HsDocTy x _)            = go' x
-        go (HsBangTy _ x)           = go' x
-        go (HsRecTy xs)             = mapM_ (go' . getBangType . cd_fld_type . unLoc) xs
-        go (HsExplicitListTy _ xs)  = mapM_ go' xs
-        go (HsExplicitTupleTy _ xs) = mapM_ go' xs
-        go (HsWrapTy _ x)           = go' (noLoc x)
-        go (HsForAllTy _ (Just l) _ _ _) = err hintNested l ty
-        go (HsForAllTy _ Nothing  _ (L _ ctxt) x)
-          | Just (L l _) <- firstMatch isWildcardTy      ctxt
-          = err hintNested l ty
-          | Just (L l _) <- firstMatch isNamedWildcardTy ctxt
-          = err hintNamed l ty
-          | otherwise               = go' x
-        go _                        = return ()
-
-
 checkDoAndIfThenElse :: LHsExpr RdrName
                      -> Bool
                      -> LHsExpr RdrName
@@ -1475,11 +1212,6 @@ mkImport :: Located CCallConv
          -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
 mkImport (L lc cconv) (L ls safety) (L loc (esrc,entity), v, ty)
-  | Just loc <- maybeLocation $ findWildcards ty
-    = parseErrorSDoc loc $
-      text "Wildcard not allowed" $$
-      text "In foreign import declaration" <+>
-      quotes (ppr v) $$ ppr ty
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
@@ -1559,8 +1291,6 @@ mkExport :: Located CCallConv
          -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
 mkExport (L lc cconv) (L le (esrc,entity), v, ty) = do
-  checkNoPartialType (ptext (sLit "In foreign export declaration") <+>
-                      quotes (ppr v) $$ ppr ty) ty
   return $ ForD (ForeignExport v ty noForeignExportCoercionYet
                  (CExport (L lc (CExportStatic esrc entity' cconv))
                           (L le (unpackFS entity))))
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index f1a18d6e0d..aa39b590db 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -813,11 +813,17 @@ renameSig _ (IdSig x)
 
 renameSig ctxt sig@(TypeSig vs ty _)
   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
-        -- (named and anonymous) wildcards are bound here.
-        ; (wcs, ty') <- extractWildcards ty
-        ; bindLocatedLocalsFV wcs $ \wcs_new -> do {
-          (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty'
-        ; return (TypeSig new_vs new_ty wcs_new, fvs) } }
+        ; let doc = ppr_sig_bndrs vs
+              wildCardsAllowed = case ctxt of
+                TopSigCtxt _    -> True
+                LocalBindCtxt _ -> True
+                _               -> False
+        ; (new_ty, fvs, wcs)
+            <- if wildCardsAllowed
+               then rnHsSigTypeWithWildCards doc ty
+               else do { (new_ty, fvs) <- rnHsSigType doc ty
+                       ; return (new_ty, fvs, []) }
+        ; return (TypeSig new_vs new_ty wcs, fvs) }
 
 renameSig ctxt sig@(GenericSig vs ty)
   = do  { defaultSigs_on <- xoptM Opt_DefaultSignatures
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 71fa1cb35b..ef77247a5d 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -247,12 +247,10 @@ rnExpr (RecordUpd expr rbinds _ _ _)
                   fvExpr `plusFV` fvRbinds) }
 
 rnExpr (ExprWithTySig expr pty PlaceHolder)
-  = do  { (wcs, pty') <- extractWildcards pty
-        ; bindLocatedLocalsFV wcs $ \wcs_new -> do {
-          (pty'', fvTy) <- rnLHsType ExprWithTySigCtx pty'
-        ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty'') $
-                             rnLExpr expr
-        ; return (ExprWithTySig expr' pty'' wcs_new, fvExpr `plusFV` fvTy) } }
+  = do  { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty
+        ; (expr', fvExpr)   <- bindSigTyVarsFV (hsExplicitTvs pty') $
+                               rnLExpr expr
+        ; return (ExprWithTySig expr' pty' wcs, fvExpr `plusFV` fvTy) }
 
 rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 93a7dfdb1c..743f460390 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -5,13 +5,15 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module RnTypes (
         -- Type related stuff
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind, rnLHsMaybeKind,
         rnHsSigType, rnLHsInstType, rnConDeclFields,
-        newTyVarNameRn,
+        newTyVarNameRn, rnLHsTypeWithWildCards,
+        rnHsSigTypeWithWildCards,
 
         -- Precence related stuff
         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
@@ -22,7 +24,7 @@ module RnTypes (
         bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
         extractRdrKindSigVars, extractDataDefnKindVars,
-        extractWildcards, filterInScope
+        filterInScope
   ) where
 
 import {-# SOURCE #-} RnSplice( rnSpliceType )
@@ -45,9 +47,13 @@ import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
 import Outputable
 import FastString
 import Maybes
-import Data.List        ( nub, nubBy )
+import Data.List        ( nub, nubBy, deleteFirstsBy )
 import Control.Monad    ( unless, when )
 
+#if __GLASGOW_HASKELL__ < 709
+import Data.Monoid      ( mappend, mempty, mconcat )
+#endif
+
 #include "HsVersions.h"
 
 {-
@@ -274,13 +280,24 @@ rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
        ; (tys', fvs) <- rnLHsTypes doc tys
        ; return (HsExplicitTupleTy kis tys', fvs) }
 
-rnHsTyKi _ _ HsWildcardTy = panic "rnHsTyKi HsWildcardTy"
-                            -- Should be replaced by a HsNamedWildcardTy
+rnHsTyKi isType _doc (HsWildCardTy (AnonWildCard PlaceHolder))
+  = ASSERT( isType )
+    do { loc <- getSrcSpanM
+       ; uniq <- newUnique
+       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
+       ; return (HsWildCardTy (AnonWildCard name), unitFV name) }
 
-rnHsTyKi isType _doc (HsNamedWildcardTy rdr_name)
+rnHsTyKi isType doc (HsWildCardTy (NamedWildCard rdr_name))
   = ASSERT( isType )
-    do { name <- rnTyVar isType rdr_name
-       ; return (HsNamedWildcardTy name, unitFV name) }
+    do { not_in_scope <- isNothing `fmap` lookupOccRn_maybe rdr_name
+       ; when not_in_scope $
+         -- When the named wild card is not in scope, it means it shouldn't be
+         -- there in the first place, i.e. rnHsSigTypeWithWildCards wasn't
+         -- used, so fail.
+         failWith $ text "Unexpected wild card:" <+> quotes (ppr rdr_name) $$
+                    docOfHsDocContext doc
+       ; name <- rnTyVar isType rdr_name
+       ; return (HsWildCardTy (NamedWildCard name), unitFV name) }
 
 --------------
 rnHsTyKiForAll :: Bool -> HsDocContext -> HsType RdrName
@@ -474,13 +491,11 @@ rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
                                                , not (tv `elemLocalRdrEnv` name_env) ]
        ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
                                                , not (kv `elemLocalRdrEnv` name_env) ]
-       ; (wcs, ty') <- extractWildcards ty
        ; bindLocalNamesFV kv_names $
          bindLocalNamesFV tv_names $
-         bindLocatedLocalsFV wcs $ \wcs_new ->
-    do { (ty'', fvs1) <- rnLHsType doc ty'
-       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty'', hswb_kvs = kv_names,
-                                             hswb_tvs = tv_names, hswb_wcs = wcs_new })
+    do { (ty', fvs1, wcs) <- rnLHsTypeWithWildCards doc ty
+       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names,
+                                             hswb_tvs = tv_names, hswb_wcs = wcs })
        ; return (res, fvs1 `plusFV` fvs2) } }
 
 overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
@@ -518,6 +533,157 @@ dataKindsErr is_type thing
     what | is_type   = ptext (sLit "type")
          | otherwise = ptext (sLit "kind")
 
+--------------------------------
+-- | Variant of @rnHsSigType@ that supports wild cards. Also returns the wild
+-- cards to bind.
+rnHsSigTypeWithWildCards :: SDoc -> LHsType RdrName
+                         -> RnM (LHsType Name, FreeVars, [Name])
+rnHsSigTypeWithWildCards doc_str = rnLHsTypeWithWildCards (TypeSigCtx doc_str)
+
+-- | Variant of @rnLHsType@ that supports wild cards. The third element of the
+-- tuple consists of the freshly generated names of the anonymous wild cards
+-- occurring in the type, as well as the names of the named wild cards in the
+-- type that are not yet in scope.
+rnLHsTypeWithWildCards  :: HsDocContext -> LHsType RdrName
+                        -> RnM (LHsType Name, FreeVars, [Name])
+rnLHsTypeWithWildCards doc ty
+  = do { -- When there is a wild card at the end of the context, remove it and
+         -- add its location as the extra-constraints wild card in the
+         -- HsForAllTy.
+         let ty' = extractExtraCtsWc `fmap` ty
+
+       ; checkValidPartialType doc ty'
+
+       ; rdr_env <- getLocalRdrEnv
+       -- Filter out named wildcards that are already in scope
+       ; let (_, wcs) = collectWildCards ty'
+             nwcs = [L loc n | L loc (NamedWildCard n) <- wcs
+                             , not (elemLocalRdrEnv n rdr_env) ]
+       ; bindLocatedLocalsRn nwcs $ \nwcs' -> do {
+         (ty'', fvs) <- rnLHsType doc ty'
+       -- Add the anonymous wildcards that have been given names during
+       -- renaming
+       ; let (_, wcs') = collectWildCards ty''
+             awcs      = filter (isAnonWildCard . unLoc) wcs'
+       ; return (ty'', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } }
+  where
+    extractExtraCtsWc (HsForAllTy flag _ bndrs (L l ctxt) ty)
+      | Just (ctxt', ct) <- snocView ctxt
+      , L lx (HsWildCardTy (AnonWildCard _)) <- ignoreParens ct
+      = HsForAllTy flag (Just lx) bndrs (L l ctxt') ty
+    extractExtraCtsWc ty = ty
+
+-- | Extract all wild cards from a type. The named and anonymous
+-- extra-constraints wild cards are returned separately to be able to give
+-- more accurate error messages.
+collectWildCards
+  :: Eq name => LHsType name
+  -> ([Located (HsWildCardInfo name)],  -- extra-constraints wild cards
+      [Located (HsWildCardInfo name)])  -- wild cards
+collectWildCards lty = (nubBy sameWildCard extra, nubBy sameWildCard wcs)
+  where
+    (extra, wcs) = go lty
+    go (L loc ty) = case ty of
+      HsAppTy ty1 ty2         -> go ty1 `mappend` go ty2
+      HsFunTy ty1 ty2         -> go ty1 `mappend` go ty2
+      HsListTy ty             -> go ty
+      HsPArrTy ty             -> go ty
+      HsTupleTy _ tys         -> gos tys
+      HsOpTy ty1 _ ty2        -> go ty1 `mappend` go ty2
+      HsParTy ty              -> go ty
+      HsIParamTy _ ty         -> go ty
+      HsEqTy ty1 ty2          -> go ty1 `mappend` go ty2
+      HsKindSig ty kind       -> go ty `mappend` go kind
+      HsDocTy ty _            -> go ty
+      HsBangTy _ ty           -> go ty
+      HsRecTy flds            -> gos $ map (cd_fld_type . unLoc) flds
+      HsExplicitListTy _ tys  -> gos tys
+      HsExplicitTupleTy _ tys -> gos tys
+      HsWrapTy _ ty           -> go (L loc ty)
+      -- Interesting cases
+      HsWildCardTy wc         -> ([], [L loc wc])
+      HsForAllTy _ _ _ (L _ ctxt) ty -> ctxtWcs `mappend` go ty
+        where
+          ctxt' = map ignoreParens ctxt
+          extraWcs  = [L l wc | L l (HsWildCardTy wc) <- ctxt']
+          (_, wcs) = gos ctxt'
+          -- Remove extra-constraints wild cards from wcs
+          ctxtWcs = (extraWcs, deleteFirstsBy sameWildCard
+                               (nubBy sameWildCard wcs) extraWcs)
+      -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
+      _ -> mempty
+    gos = mconcat . map go
+
+-- | Check the validity of a partial type signature. The following things are
+-- checked:
+--
+-- * Named extra-constraints wild cards aren't allowed,
+-- e.g. invalid: @(Show a, _x) => a -> String@.
+--
+-- * There is only one extra-constraints wild card in the context and it must
+-- come last, e.g. invalid: @(_, Show a) => a -> String@
+-- or @(_, Show a, _) => a -> String@.
+--
+-- * There should be no unnamed wild cards in the context.
+--
+-- * An extra-constraints wild card can only occur in the top-level context.
+-- This would be invalid: @(Eq a, _) => a -> (Num a, _) => a -> Bool@.
+--
+-- * Named wild cards occurring in the context must also occur in the monotype.
+--
+-- When an invalid wild card is found, we fail with an error.
+checkValidPartialType :: HsDocContext -> LHsType RdrName -> RnM ()
+checkValidPartialType doc lty
+  = do { whenNonEmpty isNamedWildCard inExtra $ \(L loc _) ->
+           failAt loc $ typeDoc $$
+           text "An extra-constraints wild card cannot be named" $$
+           docOfHsDocContext doc
+
+       ; whenNonEmpty isAnonWildCard extraTopLevel $ \(L loc _) ->
+           failAt loc $ typeDoc $$
+           -- If there was a valid extra-constraints wild card, it should have
+           -- already been removed and its location should be stored in the
+           -- HsForAllTy
+           (if isJust extra
+            then text "Only a single extra-constraints wild card is allowed"
+            else fcat [ text "An extra-constraints wild card must occur"
+                      , text "at the end of the constraints" ]) $$
+           docOfHsDocContext doc
+
+       ; whenNonEmpty isAnonWildCard inCtxt $ \(L loc _) ->
+           failAt loc $ typeDoc $$
+           text "Anonymous wild cards are not allowed in constraints" $$
+           docOfHsDocContext doc
+
+       ; whenNonEmpty isAnonWildCard nestedExtra $ \(L loc _) ->
+           failAt loc $ typeDoc $$
+           fcat [ text "An extra-constraints wild card is only allowed"
+                , text "in the top-level context" ] $$
+           docOfHsDocContext doc
+
+       ; whenNonEmpty isNamedWildCard inCtxtNotInTau $ \(L loc name) ->
+           failAt loc $ typeDoc $$
+           fcat [ text "The named wild card" <+> quotes (ppr name) <> space
+                , text "is only allowed in the constraints"
+                , text "when it also occurs in the rest of the type" ] $$
+           docOfHsDocContext doc }
+  where
+    typeDoc               = hang (text "Invalid partial type:") 2 (ppr lty)
+    (extra, ctxt, tau)    = splitPartialType lty
+    (inExtra,     _)      = collectWildCards lty
+    (nestedExtra, inTau)  = collectWildCards tau
+    (_,           inCtxt) = mconcat $ map collectWildCards ctxt
+    inCtxtNotInTau        = deleteFirstsBy sameWildCard inCtxt inTau
+    extraTopLevel         = deleteFirstsBy sameWildCard inExtra nestedExtra
+
+    splitPartialType (L _ (HsForAllTy _ extra _ (L _ ctxt) ty))
+      = (extra, map ignoreParens ctxt, ty)
+    splitPartialType ty = (Nothing, [], ty)
+
+    whenNonEmpty test wcs f
+      = whenIsJust (listToMaybe $ filter (test . unLoc) wcs) f
+
+
 {-
 *********************************************************
 *                                                      *
@@ -999,10 +1165,8 @@ extract_lty (L _ ty) acc
       HsForAllTy _ _ tvs cx ty  -> extract_hs_tv_bndrs tvs acc $
                                    extract_lctxt cx   $
                                    extract_lty ty ([],[])
-      -- We deal with these to in a later stage, because they need to be
-      -- replaced by fresh HsTyVars.
-      HsWildcardTy              -> acc
-      HsNamedWildcardTy _       -> acc
+      -- We deal with these separately in rnLHsTypeWithWildCards
+      HsWildCardTy _            -> acc
 
 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
                     -> FreeKiTyVars -> FreeKiTyVars
@@ -1023,60 +1187,3 @@ extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_tv tv acc
   | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
   | otherwise     = acc
-
--- | Replace all unnamed wildcards in the given type with named wildcards.
--- These names are freshly generated, based on "_". Return a tuple of the
--- named wildcards that weren't already in scope (amongst them the named
--- wildcards the unnamed ones were converted into), and the type in which the
--- unnamed wildcards are replaced by named wildcards.
-extractWildcards :: LHsType RdrName -> RnM ([Located RdrName], LHsType RdrName)
-extractWildcards ty
-  = do { (nwcs, awcs, ty') <- go ty
-       ; rdr_env <- getLocalRdrEnv
-       -- Filter out named wildcards that are already in scope
-       ; let nwcs' = nubBy eqLocated $ filterOut (flip (elemLocalRdrEnv . unLoc) rdr_env) nwcs
-       ; return (nwcs' ++ awcs, ty') }
-  where
-    go orig@(L l ty) = case ty of
-      (HsForAllTy exp extra bndrs (L locCxt cxt) ty) ->
-        do (nwcs1, awcs1, cxt') <- extList cxt
-           (nwcs2, awcs2, ty')  <- go ty
-           return (nwcs1 ++ nwcs2, awcs1 ++ awcs2,
-                   L l (HsForAllTy exp extra bndrs (L locCxt cxt') ty'))
-      (HsAppTy ty1 ty2)           -> go2 HsAppTy ty1 ty2
-      (HsFunTy ty1 ty2)           -> go2 HsFunTy ty1 ty2
-      (HsListTy ty)               -> go1 HsListTy ty
-      (HsPArrTy ty)               -> go1 HsPArrTy ty
-      (HsTupleTy con tys)         -> goList (HsTupleTy con) tys
-      (HsOpTy ty1 op ty2)         -> go2 (\t1 t2 -> HsOpTy t1 op t2) ty1 ty2
-      (HsParTy ty)                -> go1 HsParTy ty
-      (HsIParamTy n ty)           -> go1 (HsIParamTy n) ty
-      (HsEqTy ty1 ty2)            -> go2 HsEqTy ty1 ty2
-      (HsKindSig ty kind)         -> go2 HsKindSig ty kind
-      (HsDocTy ty doc)            -> go1 (flip HsDocTy doc) ty
-      (HsBangTy b ty)             -> go1 (HsBangTy b) ty
-      (HsExplicitListTy ptk tys)  -> goList (HsExplicitListTy ptk) tys
-      (HsExplicitTupleTy ptk tys) -> goList (HsExplicitTupleTy ptk) tys
-      HsWildcardTy                -> do
-        uniq <- newUnique
-        let name = mkInternalName uniq (mkTyVarOcc "_") l
-            rdrName = nameRdrName name
-        return ([], [L l rdrName], L l $ HsNamedWildcardTy rdrName)
-      (HsNamedWildcardTy name)    -> return ([L l name], [], orig)
-      -- HsQuasiQuoteTy, HsSpliceTy, HsRecTy, HsCoreTy, HsTyLit, HsWrapTy
-      _                           -> return ([], [], orig)
-      where
-        go1 f t = do (nwcs, awcs, t') <- go t
-                     return (nwcs, awcs, L l $ f t')
-        go2 f t1 t2 =
-          do (nwcs1, awcs1, t1') <- go t1
-             (nwcs2, awcs2, t2') <- go t2
-             return (nwcs1 ++ nwcs2, awcs1 ++ awcs2, L l $ f t1' t2')
-        extList l = do rec_res <- mapM go l
-                       let (nwcs, awcs, tys') =
-                             foldr (\(nwcs, awcs, ty) (nwcss, awcss, tys) ->
-                                     (nwcs ++ nwcss, awcs ++ awcss, ty : tys))
-                                   ([], [], []) rec_res
-                       return (nwcs, awcs, tys')
-        goList f tys = do (nwcs, awcs, tys') <- extList tys
-                          return (nwcs, awcs, L l $ f tys')
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index c34241018a..6337b3d88f 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -827,9 +827,16 @@ pprBinders bndrs  = pprWithCommas ppr bndrs
 notFound :: Name -> TcM TyThing
 notFound name
   = do { lcl_env <- getLclEnv
+       ; namedWildCardsEnabled <- xoptM Opt_NamedWildCards
        ; let stage = tcl_th_ctxt lcl_env
+             isWildCard = case getOccString name of
+               ('_':_:_) | namedWildCardsEnabled -> True
+               "_"                               -> True
+               _                                 -> False
        ; case stage of   -- See Note [Out of scope might be a staging error]
            Splice {} -> stageRestrictionError (quotes (ppr name))
+           _ | isWildCard -> failWithTc $
+                             text "Unexpected wild card:" <+> quotes (ppr name)
            _ -> failWithTc $
                 vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+>
                      ptext (sLit "is not in scope during type checking, but it passed the renamer"),
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 15d647b350..677b5a849b 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -536,12 +536,9 @@ tc_hs_type hs_ty@(HsTyLit (HsStrTy _ s)) exp_kind
        ; checkWiredInTyCon typeSymbolKindCon
        ; return (mkStrLitTy s) }
 
-
-tc_hs_type HsWildcardTy _ = panic "tc_hs_type HsWildcardTy"
--- unnamed wildcards should have been replaced by named wildcards
-
-tc_hs_type hs_ty@(HsNamedWildcardTy name) exp_kind
-  = do { (ty, k) <- tcTyVar name
+tc_hs_type hs_ty@(HsWildCardTy wc) exp_kind
+  = do { let name = wildCardName wc
+       ; (ty, k) <- tcTyVar name
        ; checkExpectedKind hs_ty k exp_kind
        ; return ty }
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index de318169c3..16c8d37ee4 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1845,11 +1845,8 @@ tcRnType :: HscEnv
 tcRnType hsc_env normalise rdr_type
   = runTcInteractive hsc_env $
     setXOptM Opt_PolyKinds $   -- See Note [Kind-generalise in tcRnType]
-    do { (wcs, rdr_type') <- extractWildcards rdr_type
-       ; (rn_type, wcs)   <- bindLocatedLocalsRn wcs $ \wcs_new -> do {
-       ; (rn_type, _fvs)  <- rnLHsType GHCiCtx rdr_type'
+    do { (rn_type, _fvs, wcs) <- rnLHsTypeWithWildCards GHCiCtx rdr_type
        ; failIfErrsM
-       ; return (rn_type, wcs_new) }
 
         -- Now kind-check the type
         -- It can have any rank or kind
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 820e969cf4..c299f29234 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -691,6 +691,9 @@ addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
 failWith :: MsgDoc -> TcRn a
 failWith msg = addErr msg >> failM
 
+failAt :: SrcSpan -> MsgDoc -> TcRn a
+failAt loc msg = addErrAt loc msg >> failM
+
 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
 -- addErrAt is mainly (exclusively?) used by the renamer, where
 -- tidying is not an issue, but it's all lazy so the extra