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

2 files changed, 12 insertions, 297 deletions

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))))