summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/DsMeta.hs7
-rw-r--r--compiler/hsSyn/HsTypes.hs77
-rw-r--r--compiler/hsSyn/PlaceHolder.hs1
-rw-r--r--compiler/parser/Parser.y35
-rw-r--r--compiler/parser/RdrHsSyn.hs274
-rw-r--r--compiler/rename/RnBinds.hs16
-rw-r--r--compiler/rename/RnExpr.hs10
-rw-r--r--compiler/rename/RnTypes.hs255
-rw-r--r--compiler/typecheck/TcEnv.hs7
-rw-r--r--compiler/typecheck/TcHsType.hs9
-rw-r--r--compiler/typecheck/TcRnDriver.hs5
-rw-r--r--compiler/typecheck/TcRnMonad.hs3
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
View Lorry Controller Status