Commit d831b6f4 authored by thomasw's avatar thomasw Committed by Austin Seipp

Implement Partial Type Signatures

Summary:
Add support for Partial Type Signatures, i.e. holes in types, see:
https://ghc.haskell.org/trac/ghc/wiki/PartialTypeSignatures

This requires an update to the Haddock submodule.

Test Plan: validate

Reviewers: austin, goldfire, simonpj

Reviewed By: simonpj

Subscribers: thomie, Iceland_jack, dominique.devriese, simonmar, carter, goldfire

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

GHC Trac Issues: #9478
parent 7460dafa
......@@ -184,7 +184,7 @@ repTopDs group@(HsGroup { hs_valds = valds
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
= [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
= [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs
, tv <- hsQTvBndrs qtvs]
where
sigs = case binds of
......@@ -687,7 +687,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
return (concat sigs1) }
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig (L loc (TypeSig nms ty _)) = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty
rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
......@@ -708,7 +708,7 @@ rep_ty_sig mk_sig loc (L _ ty) nm
where
-- We must special-case the top-level explicit for-all of a TypeSig
-- See Note [Scoped type variables in bindings]
rep_ty (HsForAllTy Explicit tvs ctxt ty)
rep_ty (HsForAllTy Explicit _ tvs ctxt ty)
= do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
......@@ -846,7 +846,7 @@ repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy (HsForAllTy _ tvs ctxt ty) =
repTy (HsForAllTy _ _ tvs ctxt ty) =
addTyVarBinds tvs $ \bndrs -> do
ctxt1 <- repLContext ctxt
ty1 <- repLTy ty
......@@ -1073,7 +1073,7 @@ repE (RecordUpd e flds _ _ _)
fs <- repFields flds;
repRecUpd x fs }
repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
repE (ArithSeq _ _ aseq) =
case aseq of
From e -> do { ds1 <- repLE e; repFrom ds1 }
......
......@@ -168,7 +168,7 @@ cvtDec (TH.FunD nm cls)
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD (TypeSig [nm'] ty') }
; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) }
cvtDec (TH.InfixD fx nm)
-- fixity signatures are allowed for variables, constructors, and types
......@@ -681,7 +681,7 @@ cvtl e = wrapL (cvt e)
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
; return $ ExprWithTySig e' t' }
; return $ ExprWithTySig e' t' PlaceHolder }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM cvtFld flds
; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
......
......@@ -424,7 +424,7 @@ plusHsValBinds _ _
getTypeSigNames :: HsValBinds a -> NameSet
-- Get the names that have a user type sig
getTypeSigNames (ValBindsOut _ sigs)
= mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names]
= mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names]
getTypeSigNames _
= panic "HsBinds.getTypeSigNames"
\end{code}
......@@ -586,10 +586,17 @@ type LSig name = Located (Sig name)
data Sig name
= -- | An ordinary type signature
-- @f :: Num a => a -> a@
-- After renaming, this list of Names contains the named and unnamed
-- wildcards brought into scope by this signature. For a signature
-- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
-- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
-- are then both replaced with fresh meta vars in the type. Their names
-- are stored in the type signature that brought them into scope, in
-- this third field to be more specific.
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
-- 'ApiAnnotation.AnnComma'
TypeSig [Located name] (LHsType name)
TypeSig [Located name] (LHsType name) (PostRn name [Name])
-- | A pattern synonym type signature
-- @pattern type forall b. (Eq b) => P a b :: forall a. (Num a) => T a
......@@ -765,7 +772,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (TypeSig vars ty _wcs) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
......
......@@ -275,6 +275,10 @@ data HsExpr id
| ExprWithTySig
(LHsExpr id)
(LHsType id)
(PostRn id [Name]) -- After renaming, the list of Names
-- contains the named and unnamed
-- wildcards brought in scope by the
-- signature
| ExprWithTySigOut -- TRANSLATION
(LHsExpr id)
......@@ -623,7 +627,7 @@ ppr_expr (RecordCon con_id _ rbinds)
ppr_expr (RecordUpd aexp rbinds _ _ _)
= hang (pprParendExpr aexp) 2 (ppr rbinds)
ppr_expr (ExprWithTySig expr sig)
ppr_expr (ExprWithTySig expr sig _)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ExprWithTySigOut expr sig)
......
......@@ -41,9 +41,10 @@ module HsTypes (
splitHsClassTy_maybe, splitLHsClassTy_maybe,
splitHsFunType,
splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
isWildcardTy, isNamedWildcardTy,
-- Printing
pprParendHsType, pprHsForAll,
pprParendHsType, pprHsForAll, pprHsForAllExtra,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
) where
......@@ -62,6 +63,7 @@ import SrcLoc
import StaticFlags
import Outputable
import FastString
import Maybes( isJust )
import Data.Data hiding ( Fixity )
import Data.Maybe ( fromMaybe )
......@@ -168,6 +170,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
}
deriving (Typeable)
deriving instance (Data name, Data thing, Data (PostRn name [Name]))
......@@ -175,7 +178,8 @@ deriving instance (Data name, Data thing, Data (PostRn name [Name]))
mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing
mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder
, hswb_tvs = PlaceHolder }
, hswb_tvs = PlaceHolder
, hswb_wcs = PlaceHolder }
-- | These names are used early on to store the names of implicit
......@@ -224,7 +228,13 @@ data HsType name
= HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way
-- the user wrote it originally, so that the printer can
-- print it as the user wrote it
(LHsTyVarBndrs name)
(Maybe SrcSpan) -- Indicates whether extra constraints may be inferred.
-- When Nothing, no, otherwise the location of the extra-
-- constraints wildcard is stored. For instance, for the
-- signature (Eq a, _) => a -> a -> Bool, this field would
-- be something like (Just 1:8), with 1:8 being line 1,
-- column 8.
(LHsTyVarBndrs name)
(LHsContext name)
(LHsType name)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
......@@ -284,6 +294,10 @@ data HsType name
| HsTyLit HsTyLit -- A promoted numeric literal.
| HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output
| HsWildcardTy -- A type wildcard
| HsNamedWildcardTy name -- A named wildcard
deriving (Typeable)
deriving instance (DataId name) => Data (HsType name)
......@@ -439,13 +453,23 @@ mkQualifiedHsForAllTy ctxt ty = mkHsForAllTy Qualified [] ctxt ty
mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
-- Smart constructor for HsForAllTy
mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp (mkHsQTvs tvs) ctxt 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
-- mk_forall_ty makes a pure for-all type (no context)
mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName
mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
mk_forall_ty exp tvs ty = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty
mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
= addExtra $ mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
where addExtra (HsForAllTy exp _ qtvs ctxt ty) = HsForAllTy exp extra qtvs ctxt ty
addExtra ty = ty -- Impossible, as mkHsForAllTy always returns a HsForAllTy
mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
mk_forall_ty exp tvs ty = HsForAllTy exp Nothing (mkHsQTvs tvs) (noLoc []) ty
-- Even if tvs is empty, we still make a HsForAll!
-- In the Implicit case, this signals the place to do implicit quantification
-- In the Explicit case, it prevents implicit quantification
......@@ -460,8 +484,8 @@ _ `plus` _ = Implicit
hsExplicitTvs :: LHsType Name -> [Name]
-- The explicitly-given forall'd type variables of a HsType
hsExplicitTvs (L _ (HsForAllTy Explicit tvs _ _)) = hsLKiTyVarNames tvs
hsExplicitTvs _ = []
hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs
hsExplicitTvs _ = []
---------------------
hsTyVarName :: HsTyVarBndr name -> name
......@@ -485,6 +509,15 @@ hsLTyVarLocName = fmap hsTyVarName
hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
---------------------
isWildcardTy :: HsType a -> Bool
isWildcardTy HsWildcardTy = True
isWildcardTy _ = False
isNamedWildcardTy :: HsType a -> Bool
isNamedWildcardTy (HsNamedWildcardTy _) = True
isNamedWildcardTy _ = False
\end{code}
......@@ -531,9 +564,9 @@ splitLHsForAllTy
-> (LHsTyVarBndrs name, HsContext name, LHsType name)
splitLHsForAllTy poly_ty
= case unLoc poly_ty of
HsParTy ty -> splitLHsForAllTy ty
HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
_ -> (emptyHsQTvs, [], poly_ty)
HsParTy ty -> splitLHsForAllTy ty
HsForAllTy _ _ tvs cxt ty -> (tvs, unLoc cxt, ty)
_ -> (emptyHsQTvs, [], poly_ty)
-- The type vars should have been computed by now, even if they were implicit
splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
......@@ -609,11 +642,22 @@ instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
instance (Outputable thing) => Outputable (HsWithBndrs name thing) where
ppr (HsWB { hswb_cts = ty }) = ppr ty
pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc
pprHsForAll exp qtvs cxt
| show_forall = forall_part <+> pprHsContext (unLoc cxt)
| otherwise = pprHsContext (unLoc cxt)
pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc
pprHsForAll exp = pprHsForAllExtra exp Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
-- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This
-- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just'
-- containing the location of the extra-constraints wildcard. A special
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
pprHsForAllExtra :: OutputableBndr name => HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name -> LHsContext name -> SDoc
pprHsForAllExtra exp extra qtvs cxt
| show_forall = forall_part <+> pprHsContextExtra show_extra (unLoc cxt)
| otherwise = pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
show_forall = opt_PprStyle_Debug
|| (not (null (hsQTvBndrs qtvs)) && is_explicit)
is_explicit = case exp of {Explicit -> True; Implicit -> False; Qualified -> False}
......@@ -630,6 +674,15 @@ pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc
pprHsContextExtra False = pprHsContext
pprHsContextExtra True
= \ctxt -> case ctxt of
[] -> char '_' <+> darrow
_ -> parens (sep (punctuate comma ctxt')) <+> darrow
where ctxt' = map ppr ctxt ++ [char '_']
pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
......@@ -671,9 +724,9 @@ ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc
ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty)
= maybeParen ctxt_prec FunPrec $
sep [pprHsForAll exp tvs ctxt, ppr_mono_lty TopPrec ty]
sep [pprHsForAllExtra exp extra tvs ctxt, ppr_mono_lty TopPrec ty]
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty
ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq
......@@ -693,6 +746,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 ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
= ppr_mono_ty ctxt_prec ty
......
......@@ -771,7 +771,7 @@ hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
, tcdSigs = sigs, tcdATs = ats }))
= L loc cls_name :
[ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
[ L mem_loc mem_name | L mem_loc (TypeSig ns _) <- sigs, L _ mem_name <- ns ]
[ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ]
hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
= L loc name : hsDataDefnBinders defn
......
......@@ -503,6 +503,7 @@ data WarningFlag =
| Opt_WarnUnsupportedLlvmVersion
| Opt_WarnInlineRuleShadowing
| Opt_WarnTypedHoles
| Opt_WarnPartialTypeSignatures
| Opt_WarnMissingExportedSigs
deriving (Eq, Show, Enum)
......@@ -621,6 +622,8 @@ data ExtensionFlag
| Opt_NegativeLiterals
| Opt_EmptyCase
| Opt_PatternSynonyms
| Opt_PartialTypeSignatures
| Opt_NamedWildcards
deriving (Eq, Enum, Show)
data SigOf = NotSigOf
......@@ -2724,6 +2727,7 @@ fWarningFlags = [
flagSpec ( "warn-tabs", Opt_WarnTabs, nop ),
flagSpec ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ),
flagSpec ( "warn-typed-holes", Opt_WarnTypedHoles, nop ),
flagSpec ( "warn-partial-type-signatures", Opt_WarnPartialTypeSignatures, nop ),
flagSpec ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ),
flagSpec ( "warn-unsafe", Opt_WarnUnsafe, setWarnUnsafe ),
flagSpec ( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ),
......@@ -2972,6 +2976,7 @@ xFlags = [
flagSpec ( "MultiWayIf", Opt_MultiWayIf, nop ),
flagSpec ( "NPlusKPatterns", Opt_NPlusKPatterns, nop ),
flagSpec ( "NamedFieldPuns", Opt_RecordPuns, nop ),
flagSpec ( "NamedWildcards", Opt_NamedWildcards, nop ),
flagSpec ( "NegativeLiterals", Opt_NegativeLiterals, nop ),
flagSpec ( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ),
flagSpec ( "NullaryTypeClasses", Opt_NullaryTypeClasses,
......@@ -2983,6 +2988,7 @@ xFlags = [
flagSpec ( "PackageImports", Opt_PackageImports, nop ),
flagSpec ( "ParallelArrays", Opt_ParallelArrays, nop ),
flagSpec ( "ParallelListComp", Opt_ParallelListComp, nop ),
flagSpec ( "PartialTypeSignatures", Opt_PartialTypeSignatures, nop ),
flagSpec ( "PatternGuards", Opt_PatternGuards, nop ),
flagSpec ( "PatternSignatures", Opt_ScopedTypeVariables,
deprecatedForExtension "ScopedTypeVariables" ),
......@@ -3175,6 +3181,7 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnWarningsDeprecations,
Opt_WarnDeprecatedFlags,
Opt_WarnTypedHoles,
Opt_WarnPartialTypeSignatures,
Opt_WarnUnrecognisedPragmas,
Opt_WarnPointlessPragmas,
Opt_WarnDuplicateConstraints,
......
......@@ -14,7 +14,7 @@ module ErrUtils (
Messages, ErrorMessages, WarningMessages,
errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
pprLocErrMsg, makeIntoWarning,
pprLocErrMsg, makeIntoWarning, isWarning,
errorsFound, emptyMessages, isEmptyMessages,
mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
......@@ -137,6 +137,10 @@ mkLocMessage severity locn msg
makeIntoWarning :: ErrMsg -> ErrMsg
makeIntoWarning err = err { errMsgSeverity = SevWarning }
isWarning :: ErrMsg -> Bool
isWarning err
| SevWarning <- errMsgSeverity err = True
| otherwise = False
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.
......
......@@ -106,7 +106,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
count_sigs sigs = sum5 (map sig_info sigs)
sig_info (FixSig _) = (1,0,0,0,0)
sig_info (TypeSig _ _) = (0,1,0,0,0)
sig_info (TypeSig _ _ _) = (0,1,0,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0,0)
sig_info (InlineSig _ _) = (0,0,0,1,0)
sig_info (GenericSig _ _) = (0,0,0,0,1)
......
......@@ -57,7 +57,7 @@ import Outputable
-- compiler/basicTypes
import RdrName
import OccName ( varName, dataName, tcClsName, tvName )
import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore )
import DataCon ( DataCon, dataConName )
import SrcLoc
import Module
......@@ -667,9 +667,10 @@ 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 ')' {% amsu (sLL $1 $> $ DefD (DefaultDecl $3))
[mj AnnDefault $1
,mo $2,mc $4] }
| 'default' '(' comma_types0 ')' {% do { def <- checkValidDefaults $3
; amsu (sLL $1 $> (DefD def))
[mj AnnDefault $1
,mo $2,mc $4] }}
| 'foreign' fdecl {% amsu (sLL $1 $> (unLoc $2))
[mj AnnForeign $1] }
| '{-# DEPRECATED' deprecations '#-}' { $2 } -- ++AZ++ TODO
......@@ -772,6 +773,8 @@ 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
; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
......@@ -1009,8 +1012,10 @@ where_decls :: { Located ([AddAnn]
,$3) }
pattern_synonym_sig :: { LSig RdrName }
: 'pattern' con '::' ptype
{ let (flag, qtvs, prov, req, ty) = unLoc $4
in sLL $1 $> $ PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty }
{% do { let (flag, qtvs, prov, req, ty) = unLoc $4
; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty
; checkValidPatSynSig sig
; return $ sLL $1 $> $ sig } }
ptype :: { Located (HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName, LHsContext RdrName, LHsType RdrName) }
: 'forall' tv_bndrs '.' ptype
......@@ -1035,13 +1040,13 @@ decl_cls : at_decl_cls { sLL $1 $> (unitOL $1) }
-- A 'default' signature used with the generic-programming extension
| 'default' infixexp '::' sigtypedoc
{% do { (TypeSig l ty) <- checkValSig $2 $4
{% do { (TypeSig l ty _) <- checkValSig $2 $4
; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty)))
[mj AnnDefault $1,mj AnnDcolon $3] } }
-- A 'default' signature used with the generic-programming extension
| 'default' infixexp '::' sigtypedoc
{% do { (TypeSig l ty) <- checkValSig $2 $4
{% do { (TypeSig l ty _) <- checkValSig $2 $4
; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty)))
[mj AnnDefault $1,mj AnnDcolon $3] } }
......@@ -1419,7 +1424,12 @@ btype :: { LHsType RdrName }
atype :: { LHsType RdrName }
: ntgtycon { sL1 $1 (HsTyVar (unLoc $1)) } -- Not including unit tuples
| tyvar { sL1 $1 (HsTyVar (unLoc $1)) } -- (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))
else (sL1 $1 (HsTyVar tv)) } }
| strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
(fst $ unLoc $1) } -- Constructor sigs only
| '{' fielddecls '}' {% amms (checkRecordSyntax
......@@ -1461,6 +1471,7 @@ atype :: { LHsType RdrName }
[mo $1, mj AnnComma $3,mc $5] }
| INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy $ getINTEGER $1 }
| STRING { sLL $1 $> $ HsTyLit $ HsStrTy $ getSTRING $1 }
| '_' { sL1 $1 $ HsWildcardTy }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
......@@ -1606,8 +1617,9 @@ gadt_constrs :: { Located [LConDecl RdrName] }
gadt_constr :: { LConDecl RdrName }
-- Returns a list because of: C,D :: ty
: con_list '::' sigtype
{%ams (sLL $1 $> $ mkGadtDecl (unLoc $1) $3)
[mj AnnDcolon $2] }
{% do { gadtDecl <- mkGadtDecl (unLoc $1) $3
; ams (sLL $1 $> $ gadtDecl)
[mj AnnDcolon $2] } }
-- Deprecated syntax for GADT record declarations
| oqtycon '{' fielddecls '}' '::' sigtype
......@@ -1779,13 +1791,16 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
:
-- See Note [Declaration/signature overlap] for why we need infixexp here
infixexp '::' sigtypedoc
{% do s <- checkValSig $1 $3
{% do ty <- checkPartialTypeSignature $3
; s <- checkValSig $1 ty
; _ <- ams (sLL $1 $> ()) [mj AnnDcolon $2]
; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) }
| var ',' sig_vars '::' sigtypedoc
{% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1:reverse (unLoc $3)) $5) ])
[mj AnnComma $2,mj AnnDcolon $4] }
{% do { ty <- checkPartialTypeSignature $5
; let sig = TypeSig ($1 : reverse (unLoc $3)) ty PlaceHolder
; ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD sig ])
[mj AnnComma $2,mj AnnDcolon $4] } }
| infix prec ops
{ sLL $1 $> $ toOL [ sLL $1 $> $ SigD
......@@ -1847,7 +1862,7 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 $3)
: infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 $3 PlaceHolder)
[mj AnnDcolon $2] }
| infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
HsFirstOrderApp True)
......@@ -2913,6 +2928,9 @@ hintExplicitForall span = do
, text "extension to enable explicit-forall syntax: \x2200 <tvs>. <type>"
]
namedWildcardsEnabled :: P Bool
namedWildcardsEnabled = liftM ((Opt_NamedWildcards `xopt`) . dflags) getPState
{-
%************************************************************************
%* *
......
......@@ -48,8 +48,12 @@ 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
......@@ -92,6 +96,8 @@ 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"
......@@ -128,6 +134,8 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr
-- 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,
......@@ -150,6 +158,104 @@ 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