Commit 058af6c9 authored by thomasw's avatar thomasw Committed by Austin Seipp

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
parent 7944a68f
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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
{-
%************************************************************************
......
......@@ -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