diff options
| author | Thomas Winant <thomas.winant@cs.kuleuven.be> | 2014-11-28 16:08:10 -0600 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2014-11-28 17:17:17 -0600 |
| commit | d831b6f41b3b89dc4a643069d5668c05a20f3c37 (patch) | |
| tree | 4f717db36c841619324cd210b9146ed8db671869 | |
| parent | 7460dafae3709218af651cb8bc47b5f03d4c25c7 (diff) | |
| download | haskell-d831b6f41b3b89dc4a643069d5668c05a20f3c37.tar.gz | |
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
219 files changed, 3394 insertions, 238 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 515d3528bf..2addbdf554 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 } diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 1a6f2cf110..56282db541 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -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)} diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e0a2193804..74e34df7b9 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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 diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 0833c3c66d..82098e2b9f 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -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) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index e3d6071c24..bfeec5a899 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 4709218faa..ed78964a63 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 11e5c32a8b..1f022e9431 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 12f484b421..61f433573b 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -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. diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 582cb31116..d32f619675 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -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) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index eb800ba1ec..7f4e7185bd 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -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 + {- %************************************************************************ %* * diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index a928470181..d5993819f2 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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 +-- 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) @@ -175,12 +281,18 @@ 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 -> LHsType RdrName -- LHS @@ -189,6 +301,9 @@ mkTySynonym :: SrcSpan mkTySynonym loc lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs ; 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 })) } @@ -197,6 +312,11 @@ mkTyFamInstEqn :: LHsType RdrName -> P (TyFamInstEqn RdrName) mkTyFamInstEqn lhs rhs = do { (tc, tparams) <- checkTyClHdr 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 ; return (TyFamEqn { tfe_tycon = tc , tfe_pats = mkHsWithBndrs tparams , tfe_rhs = rhs }) } @@ -491,13 +611,17 @@ mkSimpleConDecl name qvars cxt details mkGadtDecl :: [Located RdrName] -> LHsType RdrName -- Always a HsForAllTy - -> ConDecl RdrName + -> P (ConDecl RdrName) -- We allow C,D :: ty -- and expand it as if it had been -- C :: ty; D :: ty -- (Just like type signatures in general.) -mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau)) - = mk_gadt_con names +mkGadtDecl _ ty@(L _ (HsForAllTy _ (Just l) _ _ _)) + = parseErrorSDoc l $ + text "A constructor cannot have a partial type:" $$ + ppr ty +mkGadtDecl names (L _ (HsForAllTy imp Nothing qvars cxt tau)) + = return $ mk_gadt_con names where (details, res_ty) -- See Note [Sorting out the result type] = case tau of @@ -591,6 +715,8 @@ 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) @@ -695,16 +821,17 @@ checkAPat msg loc e0 = do ELazyPat e -> checkLPat msg e >>= (return . LazyPat) EAsPat n e -> checkLPat msg e >>= (return . AsPat n) -- view pattern is well-formed if the pattern is - EViewPat expr patE -> checkLPat msg patE >>= + EViewPat expr patE -> checkLPat msg patE >>= (return . (\p -> ViewPat expr p placeHolderType)) - ExprWithTySig e t -> do e <- checkLPat msg e - -- Pattern signatures are parsed as sigtypes, - -- but they aren't explicit forall points. Hence - -- we have to remove the implicit forall here. - let t' = case t of - L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty - other -> other - return (SigPatIn e (mkHsWithBndrs t')) + ExprWithTySig e t _ -> do e <- checkLPat msg e + -- Pattern signatures are parsed as sigtypes, + -- but they aren't explicit forall points. Hence + -- we have to remove the implicit forall here. + let t' = case t of + L _ (HsForAllTy Implicit _ _ + (L _ []) ty) -> ty + other -> other + return (SigPatIn e (mkHsWithBndrs t')) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ @@ -771,7 +898,8 @@ checkValDef :: SDoc checkValDef msg lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding - = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss + = checkPatBind msg (L (combineLocs lhs sig) + (ExprWithTySig lhs sig PlaceHolder)) grhss checkValDef msg lhs opt_sig g@(L l (_,grhss)) = do { mb_fun <- isFunLhs lhs @@ -817,7 +945,7 @@ checkValSig -> P (Sig RdrName) checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) - = return (TypeSig [L l v] ty) + = return (TypeSig [L l v] ty PlaceHolder) checkValSig lhs@(L l _) ty = parseErrorSDoc l ((text "Invalid type signature:" <+> ppr lhs <+> text "::" <+> ppr ty) @@ -838,6 +966,145 @@ checkValSig lhs@(L l _) ty foreign_RDR = mkUnqual varName (fsLit "foreign") 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 @@ -1077,6 +1344,11 @@ mkImport :: Located CCallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) mkImport (L lc cconv) (L ls safety) (L loc 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 entity Nothing True) importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget @@ -1154,9 +1426,11 @@ parseCImport cconv safety nm str sourceText = mkExport :: Located CCallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport (L lc cconv) (L le entity, v, ty) = return $ - ForD (ForeignExport v ty noForeignExportCoercionYet - (CExport (L lc (CExportStatic entity' cconv)) (L le entity))) +mkExport (L lc cconv) (L le 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 entity' cconv)) (L le entity))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 8d74c8eecd..cdb211259b 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -668,11 +668,14 @@ mkSigTvFn :: [LSig Name] -> (Name -> [Name]) mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where + extractScopedTyVars :: LHsType Name -> [Name] + extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs + extractScopedTyVars _ = [] + env :: NameEnv [Name] - env = mkNameEnv [ (name, hsLKiTyVarNames ltvs) -- Kind variables and type variables - | L _ (TypeSig names - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs - , (L _ name) <- names] + env = mkNameEnv [ (name, nwcs ++ extractScopedTyVars ty) -- Kind variables and type variables + | L _ (TypeSig names ty nwcs) <- sigs + , L _ name <- names] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all \end{code} @@ -805,10 +808,13 @@ renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) renameSig _ (IdSig x) = return (IdSig x, emptyFVs) -- Actually this never occurs -renameSig ctxt sig@(TypeSig vs ty) +renameSig ctxt sig@(TypeSig vs ty _) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (TypeSig new_vs new_ty, fvs) } + -- (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) } } renameSig ctxt sig@(GenericSig vs ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures @@ -923,8 +929,8 @@ findDupSigs sigs where expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig) expand_sig sig@(InlineSig n _) = [(n,sig)] - expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns] - expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns] + expand_sig sig@(TypeSig ns _ _) = [(n,sig) | n <- ns] + expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns] expand_sig _ = [] matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 02aab99fa1..edf16b8d3d 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -257,11 +257,13 @@ rnExpr (RecordUpd expr rbinds _ _ _) ; return (RecordUpd expr' rbinds' [] [] [], fvExpr `plusFV` fvRbinds) } -rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty - ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ +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', fvExpr `plusFV` fvTy) } + ; return (ExprWithTySig expr' pty'' wcs_new, fvExpr `plusFV` fvTy) } } rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index dab2cce8a1..02a45d0db8 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -531,7 +531,7 @@ getLocalNonValBinders fixity_env -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders hs_boot_sig_bndrs = [ L decl_loc (unLoc n) - | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns] + | L decl_loc (TypeSig ns _ _) <- val_sigs, n <- ns] ValBindsIn _ val_sigs = val_binds -- the SrcSpan attached to the input should be the span of the diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index a3e5faf0cc..f99bc810d5 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -559,7 +559,8 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload ; let all_fvs = fvs `addOneFV` unLoc tycon' ; return (tycon', - HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }, + HsWB { hswb_cts = pats', hswb_kvs = kv_names, + hswb_tvs = tv_names, hswb_wcs = [] }, payload', all_fvs) } -- type instance => use, hence addOneFV @@ -1035,7 +1036,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops] + ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _ _) <- sigs, op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index e0df3ec56e..d0877dc423 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -21,7 +21,8 @@ module RnTypes ( warnContextQuantification, warnUnusedForAlls, bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractRdrKindSigVars, extractDataDefnKindVars, filterInScope + extractRdrKindSigVars, extractDataDefnKindVars, + extractWildcards, filterInScope ) where import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) @@ -45,7 +46,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity, import Outputable import FastString import Maybes -import Data.List ( nub ) +import Data.List ( nub, nubBy ) import Control.Monad ( unless, when ) #include "HsVersions.h" @@ -133,7 +134,7 @@ rnHsKind = rnHsTyKi False rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) +rnHsTyKi isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty) = ASSERT( isType ) do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify @@ -154,9 +155,9 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) -- class C a where { op :: a -> a } tyvar_bndrs = userHsTyVarBndrs loc forall_tvs - rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty + rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty -rnHsTyKi isType doc fulltype@(HsForAllTy Qualified _ lctxt@(L _ ctxt) ty) +rnHsTyKi isType doc fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty) = ASSERT( isType ) do rdr_env <- getLocalRdrEnv loc <- getSrcSpanM @@ -168,9 +169,9 @@ rnHsTyKi isType doc fulltype@(HsForAllTy Qualified _ lctxt@(L _ ctxt) ty) -- See Note [Context quantification] warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs - rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty + rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty -rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau) +rnHsTyKi isType doc ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau) = ASSERT( isType ) do { -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not @@ -178,7 +179,7 @@ rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned - ; rnForAll doc Explicit kvs forall_tyvars lctxt tau } + ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau } rnHsTyKi isType _ (HsTyVar rdr_name) = do { name <- rnTyVar isType rdr_name @@ -324,6 +325,14 @@ 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 (HsNamedWildcardTy rdr_name) + = ASSERT( isType ) + do { name <- rnTyVar isType rdr_name + ; return (HsNamedWildcardTy name, unitFV name) } + -------------- rnTyVar :: Bool -> RdrName -> RnM Name rnTyVar is_type rdr_name @@ -340,16 +349,17 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys \begin{code} rnForAll :: HsDocContext -> HsExplicitFlag - -> [RdrName] -- Kind variables + -> Maybe SrcSpan -- Location of an extra-constraints wildcard + -> [RdrName] -- Kind variables -> LHsTyVarBndrs RdrName -- Type variables -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name, FreeVars) -rnForAll doc exp kvs forall_tyvars ctxt ty - | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt) +rnForAll doc exp extra kvs forall_tyvars ctxt ty + | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt), isNothing extra = rnHsType doc (unLoc ty) -- One reason for this case is that a type like Int# - -- starts off as (HsForAllTy Nothing [] Int), in case + -- starts off as (HsForAllTy Implicit Nothing [] Int), in case -- there is some quantification. Now that we have quantified -- and discovered there are no type variables, it's nicer to turn -- it into plain Int. If it were Int# instead of Int, we'd actually @@ -360,7 +370,7 @@ rnForAll doc exp kvs forall_tyvars ctxt ty = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars -> do { (new_ctxt, fvs1) <- rnContext doc ctxt ; (new_ty, fvs2) <- rnLHsType doc ty - ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } + ; return (HsForAllTy exp extra new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly @@ -462,10 +472,13 @@ 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 $ - do { (ty', fvs1) <- rnLHsType doc ty - ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = 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 }) ; return (res, fvs1 `plusFV` fvs2) } } overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc @@ -985,9 +998,13 @@ extract_lty (L _ ty) acc HsTyLit _ -> acc HsWrapTy _ _ -> panic "extract_lty" HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) - HsForAllTy _ tvs cx ty -> extract_hs_tv_bndrs tvs 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 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars @@ -1008,4 +1025,62 @@ 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') + \end{code} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index d0394d97d1..6cd420349e 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -31,6 +31,7 @@ import TcMType import ConLike import FamInstEnv( normaliseType ) import FamInst( tcGetFamInstEnvs ) +import Type( pprSigmaTypeExtraCts ) import TyCon import TcType import TysPrim @@ -198,7 +199,7 @@ tcHsBootSigs (ValBindsOut binds sigs) = do { checkTc (null binds) badBootDeclErr ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where - tc_boot_sig (TypeSig lnames ty) = mapM f lnames + tc_boot_sig (TypeSig lnames ty _) = mapM f lnames where f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty ; return (mkVanillaGlobal name sigma_ty) } @@ -305,16 +306,16 @@ tcValBinds :: TopLevelFlag tcValBinds top_lvl binds sigs thing_inside = do { -- Typecheck the signature - ; (poly_ids, sig_fn) <- tcExtendKindEnv2 patsyn_placeholder_kinds $ - -- See Note [Placeholder PatSyn kinds] - tcTySigs sigs + ; (poly_ids, sig_fn, nwc_tvs) <- tcExtendKindEnv2 patsyn_placeholder_kinds $ + -- See Note [Placeholder PatSyn kinds] + tcTySigs sigs ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) -- Extend the envt right away with all -- the Ids declared with type signatures - -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack - ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ do + -- Use tcExtendIdEnv3 to avoid extending the TcIdBinder stack + ; tcExtendIdEnv3 [(idName id, id) | id <- poly_ids] (mkVarSet nwc_tvs) $ do { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do { thing <- thing_inside -- See Note [Pattern synonym wrappers don't yield dependencies] @@ -442,6 +443,11 @@ tc_single top_lvl sig_fn prag_fn lbind thing_inside ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside ; return (binds1, thing) } +-- | No signature or a partial signature +noCompleteSig :: Maybe TcSigInfo -> Bool +noCompleteSig Nothing = True +noCompleteSig (Just sig) = isPartialSig sig + ------------------------ mkEdges :: TcSigFun -> LHsBinds Name -> [(LHsBind Name, BKey, [BKey])] @@ -455,7 +461,7 @@ mkEdges sig_fn binds ] where no_sig :: Name -> Bool - no_sig n = isNothing (sig_fn n) + no_sig n = noCompleteSig (sig_fn n) keyd_binds = bagToList binds `zip` [0::BKey ..] @@ -558,16 +564,17 @@ tcPolyCheck :: RecFlag -- Whether it's recursive after breaking -- it has a signature, tcPolyCheck rec_tc prag_fn sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped - , sig_theta = theta, sig_tau = tau, sig_loc = loc }) + , sig_nwcs = sig_nwcs, sig_theta = theta + , sig_tau = tau, sig_loc = loc }) bind - = do { ev_vars <- newEvVars theta + = ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards + do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) tvs = map snd tvs_w_scoped ; (ev_binds, (binds', [mono_info])) <- setSrcSpan loc $ checkConstraints skol_info tvs ev_vars $ - tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind] ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -609,8 +616,10 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list ; (qtvs, givens, mr_bites, ev_binds) <- simplifyInfer untch mono name_taus wanted - ; theta <- zonkTcThetaType (map evVarPred givens) - ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos + ; inferred_theta <- zonkTcThetaType (map evVarPred givens) + ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs inferred_theta) + mono_infos + ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports final_closed | closed && not mr_bites = TopLevel @@ -643,22 +652,26 @@ mkExport :: PragFun -- Pre-condition: the qtvs and theta are already zonked -mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) +mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id) = do { mono_ty <- zonkTcType (idType mono_id) ; poly_id <- case mb_sig of - Just TcSigInfo{ sig_id = id } -> return id - Just _ -> panic "mkExport" - Nothing -> mkInferredPolyId poly_name qtvs theta mono_ty + Nothing -> mkInferredPolyId poly_name qtvs inferred_theta mono_ty + Just (TcPatSynInfo _) -> panic "mkExport" + Just sig | isPartialSig sig + -> do { final_theta <- completeTheta inferred_theta sig + ; mkInferredPolyId poly_name qtvs final_theta mono_ty } + | otherwise + -> return (sig_id sig) -- NB: poly_id has a zonked type ; poly_id <- addInlinePrags poly_id prag_sigs ; spec_prags <- tcSpecPrags poly_id prag_sigs -- tcPrags requires a zonked poly_id - ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty + ; let sel_poly_ty = mkSigmaTy qtvs inferred_theta mono_ty ; traceTc "mkExport: check sig" - (ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id)) + (vcat [ ppr poly_name, ppr sel_poly_ty, ppr (idType poly_id) ]) -- Perform the impedence-matching and ambiguity check -- right away. If it fails, we want to fail now (and recover @@ -719,6 +732,45 @@ mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env ptext (sLit "Probable cause: the inferred type is ambiguous") ] what | inferred = ptext (sLit "inferred") | otherwise = ptext (sLit "specified") + + +-- | Report the inferred constraints for an extra-constraints wildcard/hole as +-- an error message, unless the PartialTypeSignatures flag is enabled. In this +-- case, the extra inferred constraints are accepted without complaining. +-- Returns the annotated constraints combined with the inferred constraints. +completeTheta :: TcThetaType -> TcSigInfo -> TcM TcThetaType +completeTheta _ (TcPatSynInfo _) + = panic "Extra-constraints wildcard not supported in a pattern signature" +completeTheta inferred_theta + sig@(TcSigInfo { sig_id = poly_id + , sig_extra_cts = mb_extra_cts + , sig_theta = annotated_theta }) + | Just loc <- mb_extra_cts + = do { annotated_theta <- zonkTcThetaType annotated_theta + ; let inferred_diff = minusList inferred_theta annotated_theta + final_theta = annotated_theta ++ inferred_diff + ; partial_sigs <- xoptM Opt_PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty + ; case partial_sigs of + True | warn_partial_sigs -> reportWarning $ makeIntoWarning msg + | otherwise -> return () + False -> reportError msg + ; return final_theta } + + | otherwise + = zonkTcThetaType annotated_theta + -- No extra-constraints wildcard means no extra constraints will be added + -- to the context, so just return the possibly empty (zonked) + -- annotated_theta. + where + pts_hint = text "To use the inferred type, enable PartialTypeSignatures" + mk_msg inferred_diff suppress_hint + = vcat [ hang ((text "Found hole") <+> quotes (char '_')) + 2 (text "with inferred constraints:") + <+> pprTheta inferred_diff + , if suppress_hint then empty else pts_hint + , typeSigCtxt (idName poly_id) sig ] \end{code} Note [Validity of inferred types] @@ -1110,7 +1162,8 @@ tcMonoBinds _ sig_fn no_gen binds -- Bring the monomorphic Ids, into scope for the RHSs ; let mono_info = getMonoBindInfo tc_binds - rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info] + rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info + , noCompleteSig mb_sig ] -- A monomorphic binding for each term variable that lacks -- a type sig. (Ones with a sig are already in scope.) @@ -1153,12 +1206,15 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc -- sense to have a *polymorphic* function Id at this point do { mono_name <- newLocalName name ; let mono_id = mkLocalId mono_name (sig_tau sig) + ; addErrCtxt (typeSigCtxt name sig) $ + emitWildcardHoleConstraints (sig_nwcs sig) ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) } | otherwise = do { mono_ty <- newFlexiTyVarTy openTypeKind ; mono_id <- newNoSigLetBndr no_gen name mono_ty ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) } +-- TODOT: emit Hole Constraints for wildcards tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $ mapM lookup_info (collectPatBinders pat) @@ -1183,8 +1239,9 @@ tcRhs :: TcMonoBind -> TcM (HsBind TcId) -- we *don't* bring any scoped type variables into scope -- Wny not? They are not completely rigid. -- That's why we have the special case for a single FunBind in tcMonoBinds -tcRhs (TcFunBind (_,_,mono_id) loc inf matches) +tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches) = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ + tcExtendTyVarEnv2 tvsAndNwcs $ -- NotTopLevel: it's a monomorphic binding do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf @@ -1194,6 +1251,9 @@ tcRhs (TcFunBind (_,_,mono_id) loc inf matches) , fun_co_fn = co_fn , bind_fvs = placeHolderNamesTc , fun_tick = Nothing }) } + where + tvsAndNwcs = maybe [] (\sig -> [(n, tv) | (Just n, tv) <- sig_tvs sig] + ++ sig_nwcs sig) mb_sig tcRhs (TcPatBind infos pat' grhss pat_ty) = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $ @@ -1301,23 +1361,31 @@ is wrong (eg at the top level of the module), which is over-conservative \begin{code} -tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun) +tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun, [TcTyVar]) tcTySigs hs_sigs = checkNoErrs $ -- See Note [Fail eagerly on bad signatures] - do { ty_sigs_s<- mapAndRecoverM tcTySig hs_sigs + do { (ty_sigs_s, tyvarsl) <- unzip <$> mapAndRecoverM tcTySig hs_sigs ; let ty_sigs = concat ty_sigs_s poly_ids = [id | TcSigInfo{ sig_id = id } <- ty_sigs] env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs] - ; return (poly_ids, lookupNameEnv env) } + ; return (poly_ids, lookupNameEnv env, concat tyvarsl) } -tcTySig :: LSig Name -> TcM [TcSigInfo] +tcTySig :: LSig Name -> TcM ([TcSigInfo], [TcTyVar]) tcTySig (L loc (IdSig id)) = do { sig <- instTcTySigFromId loc id - ; return [sig] } -tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty)) + ; return ([sig], []) } +tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs)) = setSrcSpan loc $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty - ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) } + pushUntouchablesM $ + do { nwc_tvs <- mapM newWildcardVarMetaKind wcs -- Generate fresh meta vars for the wildcards + ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1) hs_ty + ; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs)) + (map unLoc names) + ; return (sigs, nwc_tvs) } + where + extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra + extra_cts _ = Nothing + tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty)) = setSrcSpan loc $ do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty @@ -1340,8 +1408,8 @@ tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty)) patsig_univ = univ_tvs, patsig_prov = prov', patsig_req = req' } - ; return [TcPatSynInfo tpsi] }} -tcTySig _ = return [] + ; return ([TcPatSynInfo tpsi], []) }} +tcTySig _ = return ([], []) instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo instTcTySigFromId loc id @@ -1349,21 +1417,28 @@ instTcTySigFromId loc id (idType id) ; return (TcSigInfo { sig_id = id, sig_loc = loc , sig_tvs = [(Nothing, tv) | tv <- tvs] - , sig_theta = theta, sig_tau = tau }) } - where + , sig_nwcs = [] + , sig_theta = theta, sig_tau = tau + , sig_extra_cts = Nothing + , sig_partial = False }) } -- Hack: in an instance decl we use the selector id as -- the template; but we do *not* want the SrcSpan on the Name of -- those type variables to refer to the class decl, rather to -- the instance decl instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType - -> Name -> TcM TcSigInfo -instTcTySig hs_ty@(L loc _) sigma_ty name + -> Maybe SrcSpan -- Just loc <=> an extra-constraints + -- wildcard is present at location loc. + -> [(Name, TcTyVar)] -> Name -> TcM TcSigInfo +instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty , sig_loc = loc , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs - , sig_theta = theta, sig_tau = tau }) } + , sig_nwcs = nwcs + , sig_theta = theta, sig_tau = tau + , sig_extra_cts = extra_cts + , sig_partial = isJust extra_cts || not (null nwcs) }) } ------------------------------- data GeneralisationPlan @@ -1434,14 +1509,15 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn mono_local_binds = xopt Opt_MonoLocalBinds dflags && not closed_flag - no_sig n = isNothing (sig_fn n) + no_sig n = noCompleteSig (sig_fn n) -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature one_funbind_with_sig [lbind@(L _ (FunBind { fun_id = v }))] = case sig_fn (unLoc v) of Nothing -> Nothing - Just sig -> Just (lbind, sig) + Just sig | isPartialSig sig -> Nothing + Just sig | otherwise -> Just (lbind, sig) one_funbind_with_sig _ = Nothing @@ -1549,4 +1625,15 @@ Note [Binding scoped type variables] patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss) + +typeSigCtxt :: Name -> TcSigInfo -> SDoc +typeSigCtxt _ (TcPatSynInfo _) + = panic "Should only be called with a TcSigInfo" +typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs + , sig_theta = theta, sig_tau = tau + , sig_extra_cts = extra_cts }) + = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name) <> colon + , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts) + (mkSigmaTy (map snd tvs) theta tau)) ] + \end{code} diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 9b93815672..6488c6124c 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -151,8 +151,8 @@ canonicalize (CFunEqCan { cc_ev = ev canonicalize (CIrredEvCan { cc_ev = ev }) = canIrred ev -canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ }) - = canHole ev occ +canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole }) + = canHole ev occ hole canEvNC :: CtEvidence -> TcS (StopOrContinue Ct) -- Called only for non-canonical EvVars @@ -357,14 +357,16 @@ canIrred old_ev _ -> continueWith $ CIrredEvCan { cc_ev = new_ev } } } } -canHole :: CtEvidence -> OccName -> TcS (StopOrContinue Ct) -canHole ev occ +canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) +canHole ev occ hole_sort = do { let ty = ctEvPred ev fmode = FE { fe_ev = ev, fe_mode = FM_SubstOnly } ; (xi,co) <- flatten fmode ty -- co :: xi ~ ty ; mb <- rewriteEvidence ev xi co ; case mb of - ContinueWith new_ev -> do { emitInsoluble (CHoleCan { cc_ev = new_ev, cc_occ = occ }) + ContinueWith new_ev -> do { emitInsoluble (CHoleCan { cc_ev = new_ev + , cc_occ = occ + , cc_hole = hole_sort }) ; stopWith new_ev "Emit insoluble hole" } Stop ev s -> return (Stop ev s) } -- Found a cached copy; won't happen \end{code} diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 4e45d11091..34409b2aee 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -113,7 +113,7 @@ tcClassSigs clas sigs def_methods ; traceTc "tcClassSigs 2" (ppr clas) ; return (op_info, gen_dm_env) } where - vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] + vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty _) <- sigs] gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] @@ -219,7 +219,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) hs_ty = lookupHsSig hs_sig_fn sel_name `orElse` pprPanic "tc_dm" (ppr sel_name) - ; local_dm_sig <- instTcTySig hs_ty local_dm_ty local_dm_name + ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") <+> quotes (ppr sel_name)) @@ -314,7 +314,7 @@ emptyHsSigs = emptyNameEnv mkHsSigFun :: [LSig Name] -> HsSigFun mkHsSigFun sigs = mkNameEnv [(n, hs_ty) - | L _ (TypeSig ns hs_ty) <- sigs + | L _ (TypeSig ns hs_ty _) <- sigs , L _ n <- ns ] lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 0ef74a1f5a..cb83d1b2d9 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -27,7 +27,7 @@ module TcEnv( tcExtendKindEnv, tcExtendKindEnv2, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendLetEnv, - tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, + tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendIdEnv3, tcExtendIdBndrs, tcExtendGhciIdEnv, tcLookup, tcLookupLocated, tcLookupLocalIds, @@ -442,7 +442,7 @@ tcExtendGhciIdEnv :: [TyThing] -> TcM a -> TcM a -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction -- See Note [Initialising the type environment for GHCi] tcExtendGhciIdEnv ids thing_inside - = do { lcl_env <- tcExtendLocalTypeEnv tc_ty_things + = do { lcl_env <- tcExtendLocalTypeEnv tc_ty_things emptyVarSet ; setLclEnv lcl_env thing_inside } where tc_ty_things = [ (name, ATcId { tct_id = id @@ -480,17 +480,29 @@ tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -- The tct_closed flag really doesn't matter -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) tcExtendIdEnv2 names_w_ids thing_inside + = tcExtendIdEnv3 names_w_ids emptyVarSet thing_inside + +-- | 'tcExtendIdEnv2', but don't bind the 'TcId's in the 'TyVarSet' argument. +tcExtendIdEnv3 :: [(Name,TcId)] -> TyVarSet -> TcM a -> TcM a +-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) +tcExtendIdEnv3 names_w_ids not_actually_free thing_inside = do { stage <- getStage - ; tc_extend_local_env (NotTopLevel, thLevel stage) - [ (name, ATcId { tct_id = id + ; tc_extend_local_env2 (NotTopLevel, thLevel stage) + [ (name, ATcId { tct_id = id , tct_closed = NotTopLevel }) - | (name,id) <- names_w_ids] $ + | (name,id) <- names_w_ids] not_actually_free $ thing_inside } tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a tcExtendIdBndrs bndrs = updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) tc_extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcM a -> TcM a +tc_extend_local_env thlvl extra_env thing_inside = + tc_extend_local_env2 thlvl extra_env emptyVarSet thing_inside + +tc_extend_local_env2 :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] + -> TyVarSet -> TcM a -> TcM a +tc_extend_local_env2 thlvl extra_env not_actually_free thing_inside -- Precondition: the argument list extra_env has TcTyThings -- that ATcId or ATyVar, but nothing else -- @@ -501,9 +513,11 @@ tc_extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcM a - -- in the types, because instantiation does not look through such things -- (c) The call to tyVarsOfTypes is ok without looking through refs -tc_extend_local_env thlvl extra_env thing_inside +-- The second argument of type TyVarSet is a set of type variables +-- that are bound together with extra_env and should not be regarded +-- as free in the types of extra_env. = do { traceTc "env2" (ppr extra_env) - ; env1 <- tcExtendLocalTypeEnv extra_env + ; env1 <- tcExtendLocalTypeEnv extra_env not_actually_free ; let env2 = extend_local_env thlvl extra_env env1 ; setLclEnv env2 thing_inside } where @@ -520,8 +534,8 @@ tc_extend_local_env thlvl extra_env thing_inside , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs [(n, thlvl) | (n, ATcId {}) <- pairs] } -tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcM TcLclEnv -tcExtendLocalTypeEnv tc_ty_things +tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TyVarSet -> TcM TcLclEnv +tcExtendLocalTypeEnv tc_ty_things not_actually_free | isEmptyVarSet extra_tvs = do { lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) <- getLclEnv ; return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) } @@ -532,13 +546,14 @@ tcExtendLocalTypeEnv tc_ty_things ; return (lcl_env { tcl_tyvars = new_g_var , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) } where - extra_tvs = foldr get_tvs emptyVarSet tc_ty_things + extra_tvs = foldr get_tvs emptyVarSet tc_ty_things `minusVarSet` not_actually_free get_tvs (_, ATcId { tct_id = id, tct_closed = closed }) tvs = case closed of - TopLevel -> ASSERT2( isEmptyVarSet (tyVarsOfType (idType id)), ppr id $$ ppr (idType id) ) + TopLevel -> ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs - NotTopLevel -> tvs `unionVarSet` tyVarsOfType (idType id) + NotTopLevel -> tvs `unionVarSet` id_tvs + where id_tvs = tyVarsOfType (idType id) get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars] = tvs `unionVarSet` tyVarsOfType (tyVarKind tv) `extendVarSet` tv diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index cd5879c7bf..5c2e5fc6cb 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -33,7 +33,7 @@ import Var import VarSet import VarEnv import Bag -import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) +import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg, isWarning ) import BasicTypes import Util import FastString @@ -102,8 +102,9 @@ reportUnsolved wanted ; defer_errors <- goptM Opt_DeferTypeErrors ; defer_holes <- goptM Opt_DeferTypedHoles ; warn_holes <- woptM Opt_WarnTypedHoles + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures ; report_unsolved (Just binds_var) defer_errors defer_holes - warn_holes wanted + warn_holes warn_partial_sigs wanted ; getTcEvBinds binds_var } reportAllUnsolved :: WantedConstraints -> TcM () @@ -111,17 +112,20 @@ reportAllUnsolved :: WantedConstraints -> TcM () -- See Note [Deferring coercion errors to runtime] reportAllUnsolved wanted = do warn_holes <- woptM Opt_WarnTypedHoles - report_unsolved Nothing False False warn_holes wanted + warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + report_unsolved Nothing False False warn_holes warn_partial_sigs wanted report_unsolved :: Maybe EvBindsVar -- cec_binds -> Bool -- cec_defer_type_errors -> Bool -- cec_defer_holes -> Bool -- cec_warn_holes + -> Bool -- cec_warn_partial_type_signatures -> WantedConstraints -> TcM () -- Important precondition: -- WantedConstraints are fully zonked and unflattened, that is, -- zonkWC has already been applied to these constraints. -report_unsolved mb_binds_var defer_errors defer_holes warn_holes wanted +report_unsolved mb_binds_var defer_errors defer_holes warn_holes + warn_partial_sigs wanted | isEmptyWC wanted = return () | otherwise @@ -138,6 +142,7 @@ report_unsolved mb_binds_var defer_errors defer_holes warn_holes wanted , cec_defer_type_errors = defer_errors , cec_defer_holes = defer_holes , cec_warn_holes = warn_holes + , cec_warn_partial_type_signatures = warn_partial_sigs , cec_suppress = False -- See Note [Suppressing error messages] , cec_binds = mb_binds_var } @@ -171,7 +176,11 @@ data ReportErrCtxt -- Irrelevant if cec_binds = Nothing , cec_warn_holes :: Bool -- True <=> -fwarn-typed-holes - -- Controls whether holes produce warnings + -- Controls whether typed holes produce warnings + , cec_warn_partial_type_signatures :: Bool + -- True <=> -fwarn-partial-type-signatures + -- Controls whether holes in partial type + -- signatures produce warnings , cec_suppress :: Bool -- True <=> More important errors have occurred, -- so create bindings if need be, but -- don't issue any more errors/warnings @@ -248,8 +257,8 @@ reportFlats ctxt flats -- Here 'flats' includes insolble goals [ -- First deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons) -- or Int ~ t a (AppTy on one side) - ("Utterly wrong", utterly_wrong, True, mkGroupReporter mkEqErr) - , ("Holes", is_hole, True, mkHoleReporter mkHoleError) + ("Utterly wrong", utterly_wrong, True, mkGroupReporter mkEqErr) + , ("Holes", is_hole, False, mkHoleReporter mkHoleError) -- Report equalities of form (a~ty). They are usually -- skolem-equalities, and they cause confusing knock-on @@ -365,6 +374,13 @@ reportGroup mk_err ctxt cts maybeReportHoleError :: ReportErrCtxt -> ErrMsg -> TcM () maybeReportHoleError ctxt err + -- When -XPartialTypeSignatures is on, warnings (instead of errors) are + -- generated for holes in partial type signatures. Unless + -- -fwarn_partial_type_signatures is not on, in which case the messages are + -- discarded. + | isWarning err + = when (cec_warn_partial_type_signatures ctxt) + (reportWarning err) | cec_defer_holes ctxt = when (cec_warn_holes ctxt) (reportWarning (makeIntoWarning err)) @@ -401,7 +417,7 @@ addDeferredBinding ctxt err ct maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () maybeAddDeferredHoleBinding ctxt err ct - | cec_defer_holes ctxt + | cec_defer_holes ctxt && isTypedHoleCt ct = addDeferredBinding ctxt err ct | otherwise = return () @@ -563,15 +579,22 @@ mkIrredErr ctxt cts ---------------- mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg mkHoleError ctxt ct@(CHoleCan { cc_occ = occ }) - = do { let tyvars = varSetElems (tyVarsOfCt ct) + = do { partial_sigs <- xoptM Opt_PartialTypeSignatures + ; let tyvars = varSetElems (tyVarsOfCt ct) tyvars_msg = map loc_msg tyvars msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ)) 2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct))) - , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ] + , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) + , if in_typesig && not partial_sigs then pts_hint else empty ] ; (ctxt, binds_doc) <- relevantBindings False ctxt ct -- The 'False' means "don't filter the bindings; see Trac #8191 - ; mkErrorMsg ctxt ct (msg $$ binds_doc) } + ; errMsg <- mkErrorMsg ctxt ct (msg $$ binds_doc) + ; if in_typesig && partial_sigs + then return $ makeIntoWarning errMsg + else return errMsg } where + in_typesig = not $ isTypedHoleCt ct + pts_hint = ptext (sLit "To use the inferred type, enable PartialTypeSignatures") loc_msg tv = case tcTyVarDetails tv of SkolemTv {} -> quotes (ppr tv) <+> skol_msg @@ -1320,7 +1343,7 @@ quickFlattenTy (TyConApp tc tys) | otherwise = do { let (funtys,resttys) = splitAt (tyConArity tc) tys -- Ignore the arguments of the type family funtys - ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys)) + ; v <- newMetaTyVar (TauTv False) (typeKind (TyConApp tc funtys)) ; flat_resttys <- mapM quickFlattenTy resttys ; return (foldl AppTy (mkTyVarTy v) flat_resttys) } \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d7af47cb2a..a1d9b6a623 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -133,7 +133,8 @@ tcHole occ res_ty ; name <- newSysName occ ; let ev = mkLocalId name ty ; loc <- getCtLoc HoleOrigin - ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ } + ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ + , cc_hole = ExprHole } ; emitInsoluble can ; tcWrapResult (HsVar ev) ty res_ty } \end{code} @@ -212,9 +213,10 @@ tcExpr e@(HsLamCase _ matches) res_ty , ptext (sLit "requires")] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (ExprWithTySig expr sig_ty) res_ty - = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty - +tcExpr (ExprWithTySig expr sig_ty wcs) res_ty + = do { nwc_tvs <- mapM newWildcardVarMetaKind wcs + ; tcExtendTyVarEnv nwc_tvs $ do { + sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty ; (gen_fn, expr') <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> @@ -228,7 +230,9 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty - ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } + ; addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $ + emitWildcardHoleConstraints (zip wcs nwc_tvs) + ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } } tcExpr (HsType ty) _ = failWithTc (text "Can't handle type argument:" <+> ppr ty) diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index dda2cf874c..9b5ef8bbfe 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1341,7 +1341,7 @@ gen_Data_binds dflags loc tycon genDataTyCon :: (LHsBind RdrName, LSig RdrName) genDataTyCon -- $dT = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder)) where rdr_name = mk_data_type_name tycon sig_ty = nlHsTyVar dataType_RDR @@ -1353,7 +1353,7 @@ gen_Data_binds dflags loc tycon genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) genDataDataCon dc -- $cT1 etc = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder)) where rdr_name = mk_constr_name dc sig_ty = nlHsTyVar constr_RDR @@ -1947,7 +1947,8 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty -- variables refer to the ones bound in the user_ty (_, _, tau_ty') = tcSplitSigmaTy tau_ty - nlExprWithTySig e s = noLoc (ExprWithTySig e s) + nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName + nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder) \end{code} %************************************************************************ @@ -1971,7 +1972,7 @@ fiddling around. genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) genAuxBindSpec loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) where rdr_name = con2tag_RDR tycon @@ -1997,7 +1998,7 @@ genAuxBindSpec loc (DerivTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) where sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon @@ -2006,7 +2007,7 @@ genAuxBindSpec loc (DerivTag2Con tycon) genAuxBindSpec loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) where rdr_name = maxtag_RDR tycon sig_ty = HsCoreTy intTy diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 5ff622b3dc..4d4484cfa9 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -718,7 +718,7 @@ zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e ; return (ExprWithTySigOut e' ty) } -zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" +zonkExpr _ (ExprWithTySig _ _ _) = panic "zonkExpr env:ExprWithTySig" zonkExpr env (ArithSeq expr wit info) = do new_expr <- zonkExpr env expr diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 722d162ecb..62611a31a4 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -193,7 +193,7 @@ tcHsInstHead user_ctxt lhs_ty@(L loc hs_ty) ; checkValidInstance user_ctxt lhs_ty inst_ty } tc_inst_head :: HsType Name -> TcM TcType -tc_inst_head (HsForAllTy _ hs_tvs hs_ctxt hs_ty) +tc_inst_head (HsForAllTy _ _ hs_tvs hs_ctxt hs_ty) = tcHsTyVarBndrs hs_tvs $ \ tvs -> do { ctxt <- tcHsContext hs_ctxt ; ty <- tc_lhs_type hs_ty ekConstraint -- Body for forall has kind Constraint @@ -389,7 +389,7 @@ tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] --------- Foralls -tc_hs_type hs_ty@(HsForAllTy _ hs_tvs context ty) exp_kind@(EK exp_k _) +tc_hs_type hs_ty@(HsForAllTy _ _ hs_tvs context ty) exp_kind@(EK exp_k _) | isConstraintKind exp_k = failWithTc (hang (ptext (sLit "Illegal constraint:")) 2 (ppr hs_ty)) @@ -533,6 +533,15 @@ 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 + ; checkExpectedKind hs_ty k exp_kind + ; return ty } + --------------------------- tupKindSort_maybe :: TcKind -> Maybe TupleSort tupKindSort_maybe k @@ -1231,24 +1240,29 @@ Historical note: \begin{code} tcHsPatSigType :: UserTypeCtxt -> HsWithBndrs Name (LHsType Name) -- The type signature - -> TcM ( Type -- The signature - , [(Name, TcTyVar)] ) -- The new bit of type environment, binding + -> TcM ( Type -- The signature + , [(Name, TcTyVar)] -- The new bit of type environment, binding -- the scoped type variables + , [(Name, TcTyVar)] ) -- The wildcards -- Used for type-checking type signatures in -- (a) patterns e.g f (x::Int) = e -- (b) result signatures e.g. g x :: Int = e -- (c) RULE forall bndrs e.g. forall (x::Int). f x = x -tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig_tvs }) +tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, + hswb_tvs = sig_tvs, hswb_wcs = sig_wcs }) = addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $ do { kvs <- mapM new_kv sig_kvs ; tvs <- mapM new_tv sig_tvs - ; let ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs) - ; sig_ty <- tcExtendTyVarEnv2 ktv_binds $ + ; nwc_tvs <- mapM newWildcardVarMetaKind sig_wcs + ; let nwc_binds = sig_wcs `zip` nwc_tvs + ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs) + ; sig_ty <- tcExtendTyVarEnv2 (ktv_binds ++ nwc_binds) $ tcHsLiftedType hs_ty ; sig_ty <- zonkSigType sig_ty ; checkValidType ctxt sig_ty - ; return (sig_ty, ktv_binds) } + ; emitWildcardHoleConstraints (zip sig_wcs nwc_tvs) + ; return (sig_ty, ktv_binds, nwc_binds) } where new_kv name = new_tkv name superKind new_tv name = do { kind <- newMetaKindVar @@ -1265,10 +1279,11 @@ tcPatSig :: Bool -- True <=> pattern binding -> TcM (TcType, -- The type to use for "inside" the signature [(Name, TcTyVar)], -- The new bit of type environment, binding -- the scoped type variables + [(Name, TcTyVar)], -- The wildcards HsWrapper) -- Coercion due to unification with actual ty -- Of shape: res_ty ~ sig_ty tcPatSig in_pat_bind sig res_ty - = do { (sig_ty, sig_tvs) <- tcHsPatSigType PatSigCtxt sig + = do { (sig_ty, sig_tvs, sig_nwcs) <- tcHsPatSigType PatSigCtxt sig -- sig_tvs are the type variables free in 'sig', -- and not already in scope. These are the ones -- that should be brought into scope @@ -1277,7 +1292,7 @@ tcPatSig in_pat_bind sig res_ty -- Just do the subsumption check and return wrap <- addErrCtxtM (mk_msg sig_ty) $ tcSubType_NC PatSigCtxt res_ty sig_ty - ; return (sig_ty, [], wrap) + ; return (sig_ty, [], sig_nwcs, wrap) } else do -- Type signature binds at least one scoped type variable @@ -1302,7 +1317,7 @@ tcPatSig in_pat_bind sig res_ty tcSubType_NC PatSigCtxt res_ty sig_ty -- Phew! - ; return (sig_ty, sig_tvs, wrap) + ; return (sig_ty, sig_tvs, sig_nwcs, wrap) } } where mk_msg sig_ty tidy_env diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 8a15acae55..acb5ae2f6d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -928,7 +928,7 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; local_meth_sig <- case lookupHsSig sig_fn sel_name of Just hs_ty -- There is a signature in the instance declaration -> do { sig_ty <- check_inst_sig hs_ty - ; instTcTySig hs_ty sig_ty local_meth_name } + ; instTcTySig hs_ty sig_ty Nothing [] local_meth_name } Nothing -- No type signature -> do { loc <- getSrcSpanM @@ -1476,8 +1476,8 @@ Note carefully: instDeclCtxt1 :: LHsType Name -> SDoc instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (case unLoc hs_inst_ty of - HsForAllTy _ _ _ (L _ ty') -> ppr ty' - _ -> ppr hs_inst_ty) -- Don't expect this + HsForAllTy _ _ _ _ (L _ ty') -> ppr ty' + _ -> ppr hs_inst_ty) -- Don't expect this instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 233ae7930b..dfe9f21159 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -57,6 +57,10 @@ module TcMType ( zonkEvVar, zonkWC, zonkFlats, zonkId, zonkCt, zonkSkolemInfo, tcGetGlobalTyVars, + + -------------------------------- + -- (Named) Wildcards + newWildcardVar, newWildcardVarMetaKind ) where #include "HsVersions.h" @@ -103,7 +107,7 @@ kind_var_occ = mkOccName tvName "k" newMetaKindVar :: TcM TcKind newMetaKindVar = do { uniq <- newUnique - ; details <- newMetaDetails TauTv + ; details <- newMetaDetails (TauTv False) ; let kv = mkTcTyVar (mkKindName uniq) superKind details ; return (mkTyVarTy kv) } @@ -313,13 +317,20 @@ newMetaTyVar meta_info kind = do { uniq <- newUnique ; let name = mkTcTyVarName uniq s s = case meta_info of - ReturnTv -> fsLit "r" - TauTv -> fsLit "t" - FlatMetaTv -> fsLit "fmv" - SigTv -> fsLit "a" + ReturnTv -> fsLit "r" + TauTv True -> fsLit "w" + TauTv False -> fsLit "t" + FlatMetaTv -> fsLit "fmv" + SigTv -> fsLit "a" ; details <- newMetaDetails meta_info ; return (mkTcTyVar name kind details) } +newNamedMetaTyVar :: Name -> MetaInfo -> Kind -> TcM TcTyVar +-- Make a new meta tyvar out of thin air +newNamedMetaTyVar name meta_info kind + = do { details <- newMetaDetails meta_info + ; return (mkTcTyVar name kind details) } + newSigTyVar :: Name -> Kind -> TcM TcTyVar newSigTyVar name kind = do { uniq <- newUnique @@ -440,7 +451,7 @@ writeMetaTyVarRef tyvar ref ty \begin{code} newFlexiTyVar :: Kind -> TcM TcTyVar -newFlexiTyVar kind = newMetaTyVar TauTv kind +newFlexiTyVar kind = newMetaTyVar (TauTv False) kind newFlexiTyVarTy :: Kind -> TcM TcType newFlexiTyVarTy kind = do @@ -468,7 +479,7 @@ tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar) -- an existing TyVar. We substitute kind variables in the kind. tcInstTyVarX subst tyvar = do { uniq <- newUnique - ; details <- newMetaDetails TauTv + ; details <- newMetaDetails (TauTv False) ; let name = mkSystemName uniq (getOccName tyvar) kind = substTy subst (tyVarKind tyvar) new_tv = mkTcTyVar name kind details @@ -591,13 +602,23 @@ skolemiseUnboundMetaTyVar tv details -- ie where we are generalising ; uniq <- newUnique -- Remove it from TcMetaTyVar unique land ; kind <- zonkTcKind (tyVarKind tv) - ; let final_kind = defaultKind kind - final_name = mkInternalName uniq (getOccName tv) span + ; let tv_name = getOccName tv + new_tv_name = if isWildcardVar tv + then generaliseWildcardVarName tv_name + else tv_name + final_name = mkInternalName uniq new_tv_name span + final_kind = defaultKind kind final_tv = mkTcTyVar final_name final_kind details ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } + where + -- If a wildcard type called _a is generalised, we rename it to tw_a + generaliseWildcardVarName :: OccName -> OccName + generaliseWildcardVarName name | startsWithUnderscore name + = mkOccNameFS (occNameSpace name) (appendFS (fsLit "w") (occNameFS name)) + generaliseWildcardVarName name = name \end{code} Note [Zonking to Skolem] @@ -988,3 +1009,32 @@ tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) tidySkolemInfo env info = (env, info) \end{code} +%************************************************************************ +%* * + (Named) Wildcards +%* * +%************************************************************************ + +\begin{code} + + +-- | Create a new meta var with the given kind. This meta var should be used +-- to replace a wildcard in a type. Such a wildcard meta var can be +-- distinguished from other meta vars with the 'isWildcardVar' function. +newWildcardVar :: Name -> Kind -> TcM TcTyVar +newWildcardVar name kind = newNamedMetaTyVar name (TauTv True) kind + +-- | Create a new meta var (which can unify with a type of any kind). This +-- meta var should be used to replace a wildcard in a type. Such a wildcard +-- meta var can be distinguished from other meta vars with the 'isWildcardVar' +-- function. +newWildcardVarMetaKind :: Name -> TcM TcTyVar +newWildcardVarMetaKind name = do kind <- newMetaKindVar + newWildcardVar name kind + +-- | Return 'True' if the argument is a meta var created for a wildcard (by +-- 'newWildcardVar' or 'newWildcardVarMetaKind'). +isWildcardVar :: TcTyVar -> Bool +isWildcardVar tv | isTcTyVar tv, MetaTv (TauTv True) _ _ <- tcTyVarDetails tv = True +isWildcardVar _ = False +\end{code} diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index de60fcb685..3b7b5df88a 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -10,7 +10,7 @@ TcPat: Typechecking patterns module TcPat ( tcLetPat, TcSigFun, TcPragFun , TcSigInfo(..), TcPatSynInfo(..) - , findScopedTyVars + , findScopedTyVars, isPartialSig , LetBndrSpec(..), addInlinePrags, warnPrags , tcPat, tcPats, newNoSigLetBndr , addDataConStupidTheta, badFieldCon, polyPatSig ) where @@ -146,12 +146,25 @@ data TcSigInfo -- Just n <=> this skolem is lexically in scope with name n -- See Note [Binding scoped type variables] + sig_nwcs :: [(Name, TcTyVar)], + -- Instantiated wildcard variables + sig_theta :: TcThetaType, -- Instantiated theta + sig_extra_cts :: Maybe SrcSpan, -- Just loc <=> An extra-constraints + -- wildcard was present. Any extra + -- constraints inferred during + -- type-checking will be added to the + -- partial type signature. Stores the + -- location of the wildcard. + sig_tau :: TcSigmaType, -- Instantiated tau -- See Note [sig_tau may be polymorphic] - sig_loc :: SrcSpan -- The location of the signature + sig_loc :: SrcSpan, -- The location of the signature + + sig_partial :: Bool -- True <=> a partial type signature + -- containing wildcards } | TcPatSynInfo TcPatSynInfo @@ -188,7 +201,7 @@ instance NamedThing TcSigInfo where getName (TcPatSynInfo tpsi) = patsig_name tpsi instance Outputable TcSigInfo where - ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) + ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau }) = ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau) , ppr (map fst tyvars) ] ppr (TcPatSynInfo tpsi) = text "TcPatSynInfo" <+> ppr tpsi @@ -196,6 +209,8 @@ instance Outputable TcSigInfo where instance Outputable TcPatSynInfo where ppr (TPSI{ patsig_name = name}) = ppr name +isPartialSig :: TcSigInfo -> Bool +isPartialSig = sig_partial \end{code} Note [Binding scoped type variables] @@ -505,10 +520,10 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside -- Type signatures in patterns -- See Note [Pattern coercions] below tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside - = do { (inner_ty, tv_binds, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty - ; (pat', res) <- tcExtendTyVarEnv2 tv_binds $ + = do { (inner_ty, tv_binds, nwc_binds, wrap) <- tcPatSig (inPatBind penv) + sig_ty pat_ty + ; (pat', res) <- tcExtendTyVarEnv2 (tv_binds ++ nwc_binds) $ tc_lpat pat inner_ty penv thing_inside - ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } ------------------------ diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index 23262f3db8..c9a5ba88b0 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -370,6 +370,9 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat , sig_theta = worker_theta , sig_tau = worker_tau , sig_loc = noSrcSpan + , sig_extra_cts = Nothing + , sig_partial = False + , sig_nwcs = [] } ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) @@ -514,9 +517,9 @@ tcPatToExpr args = go go1 (LitPat lit) = return $ HsLit lit go1 (NPat n Nothing _) = return $ HsOverLit n go1 (NPat n (Just neg) _) = return $ noLoc neg `HsApp` noLoc (HsOverLit n) - go1 (SigPatIn pat (HsWB ty _ _)) + go1 (SigPatIn pat (HsWB ty _ _ wcs)) = do { expr <- go pat - ; return $ ExprWithTySig expr ty } + ; return $ ExprWithTySig expr ty wcs } go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" go1 (SigPatOut{}) = panic "SigPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 7982e91467..0ca12bfbfc 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1699,12 +1699,12 @@ getGhciStepIO = do ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) stepTy :: LHsType Name -- Renamed, so needs all binders in place - stepTy = noLoc $ HsForAllTy Implicit + stepTy = noLoc $ HsForAllTy Implicit Nothing (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)] , hsq_kvs = [] }) (noLoc []) (nlHsFunTy ghciM ioM) - step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy + step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy [] return step isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 146e1b72fc..a4e1e11c13 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1163,6 +1163,13 @@ captureUntouchables thing_inside thing_inside ; return (res, untch') } +pushUntouchablesM :: TcM a -> TcM a +pushUntouchablesM thing_inside + = do { env <- getLclEnv + ; let untch' = pushUntouchables (tcl_untch env) + ; setLclEnv (env { tcl_untch = untch' }) + thing_inside } + getUntouchables :: TcM Untouchables getUntouchables = do { env <- getLclEnv ; return (tcl_untch env) } @@ -1194,6 +1201,18 @@ traceTcConstraints msg ; lie <- readTcRef lie_var ; traceTc (msg ++ ": LIE:") (ppr lie) } + +emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM () +emitWildcardHoleConstraints wcs + = do { ctLoc <- getCtLoc HoleOrigin + ; forM_ wcs $ \(name, tv) -> do { + ; let ctLoc' = setCtLocSpan ctLoc (nameSrcSpan name) + ty = mkTyVarTy tv + ev = mkLocalId name ty + can = CHoleCan { cc_ev = CtWanted ty ev ctLoc' + , cc_occ = occName name + , cc_hole = TypeHole } + ; emitInsoluble can } } \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 9ec93955ee..e14733c587 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -49,7 +49,7 @@ module TcRnTypes( isEmptyCts, isCTyEqCan, isCFunEqCan, isCDictCan_Maybe, isCFunEqCan_maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt, isHoleCt, + isGivenCt, isHoleCt, isTypedHoleCt, ctEvidence, ctLoc, ctPred, mkNonCanonical, mkNonCanonicalCt, ctEvPred, ctEvLoc, ctEvTerm, ctEvCoercion, ctEvId, ctEvCheckDepth, @@ -64,7 +64,7 @@ module TcRnTypes( bumpSubGoalDepth, subGoalCounterValue, subGoalDepthExceeded, CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, ctLocDepth, bumpCtLocDepth, - setCtLocOrigin, setCtLocEnv, + setCtLocOrigin, setCtLocEnv, setCtLocSpan, CtOrigin(..), pprCtOrigin, pushErrCtxt, pushErrCtxtSameOrigin, @@ -84,7 +84,7 @@ module TcRnTypes( pprArising, pprArisingAt, -- Misc other types - TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds + TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds, HoleSort(..) ) where @@ -1065,9 +1065,15 @@ data Ct | CHoleCan { -- Treated as an "insoluble" constraint -- See Note [Insoluble constraints] - cc_ev :: CtEvidence, - cc_occ :: OccName -- The name of this hole + cc_ev :: CtEvidence, + cc_occ :: OccName, -- The name of this hole + cc_hole :: HoleSort -- The sort of this hole (expr, type, ...) } + +-- | Used to indicate which sort of hole we have. +data HoleSort = ExprHole -- ^ A hole in an expression (TypedHoles) + | TypeHole -- ^ A hole in a type (PartialTypeSignatures) + \end{code} Note [Kind orientation for CTyEqCan] @@ -1239,6 +1245,9 @@ isHoleCt:: Ct -> Bool isHoleCt (CHoleCan {}) = True isHoleCt _ = False +isTypedHoleCt :: Ct -> Bool +isTypedHoleCt (CHoleCan { cc_hole = ExprHole }) = True +isTypedHoleCt _ = False \end{code} \begin{code} @@ -1323,7 +1332,10 @@ isEmptyWC (WC { wc_flat = f, wc_impl = i, wc_insol = n }) insolubleWC :: WantedConstraints -> Bool -- True if there are any insoluble constraints in the wanted bag -insolubleWC wc = not (isEmptyBag (wc_insol wc)) +insolubleWC wc = not (isEmptyBag (filterBag isTypedHoleCt (wc_insol wc))) +-- TODOT actually, a wildcard constraint (CHoleCan originating from a wildcard +-- in a partial type signature) is not insulible. +-- insolubleWC wc = not (isEmptyBag (wc_insol wc)) || anyBag ic_insol (wc_impl wc) andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints @@ -1710,6 +1722,9 @@ ctLocOrigin = ctl_origin ctLocSpan :: CtLoc -> SrcSpan ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl +setCtLocSpan :: CtLoc -> SrcSpan -> CtLoc +setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (lcl { tcl_loc = loc }) + bumpCtLocDepth :: SubGoalCounter -> CtLoc -> CtLoc bumpCtLocDepth cnt loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth cnt d } diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index cd4776f69a..dc150c5d58 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -208,7 +208,7 @@ tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a = do { let ctxt = RuleSigCtxt name - ; (id_ty, tv_prs) <- tcHsPatSigType ctxt rn_ty + ; (id_ty, tv_prs, _) <- tcHsPatSigType ctxt rn_ty ; let id = mkLocalId name id_ty tvs = map snd tv_prs -- tcHsPatSigType returns (Name,TyVar) pairs diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 4bd3393103..9355e3b498 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1552,7 +1552,7 @@ instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) instFlexiTcSHelper :: Name -> Kind -> TcM TcType instFlexiTcSHelper tvname kind = do { uniq <- TcM.newUnique - ; details <- TcM.newMetaDetails TauTv + ; details <- TcM.newMetaDetails (TauTv False) ; let name = setNameUnique tvname uniq ; return (mkTyVarTy (mkTcTyVar name kind details)) } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 300b18cf4c..ca69856fe8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -487,7 +487,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (TypeSig _ op_ty) = discardResult (tcHsLiftedType op_ty) + kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty) kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) kc_sig _ = return () diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index c2c23bdb00..1d3ee40aca 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -340,9 +340,11 @@ instance Outputable MetaDetails where ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty data MetaInfo - = TauTv -- This MetaTv is an ordinary unification variable + = TauTv Bool -- This MetaTv is an ordinary unification variable -- A TauTv is always filled in with a tau-type, which - -- never contains any ForAlls + -- never contains any ForAlls. + -- The boolean is true when the meta var originates + -- from a wildcard. | ReturnTv -- Can unify with *anything*. Used to convert a -- type "checking" algorithm into a type inference algorithm. @@ -519,10 +521,11 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) = pp_info <> colon <> ppr untch where pp_info = case info of - ReturnTv -> ptext (sLit "ret") - TauTv -> ptext (sLit "tau") - SigTv -> ptext (sLit "sig") - FlatMetaTv -> ptext (sLit "fuv") + ReturnTv -> ptext (sLit "ret") + TauTv True -> ptext (sLit "tau") + TauTv False -> ptext (sLit "twc") + SigTv -> ptext (sLit "sig") + FlatMetaTv -> ptext (sLit "fuv") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) @@ -1257,7 +1260,7 @@ canUnifyWithPolyType dflags details kind = case details of MetaTv { mtv_info = ReturnTv } -> True -- See Note [ReturnTv] MetaTv { mtv_info = SigTv } -> False - MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags + MetaTv { mtv_info = TauTv _ } -> xopt Opt_ImpredicativeTypes dflags || isOpenTypeKind kind -- Note [OpenTypeKind accepts foralls] _other -> True diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index 32dda3c613..e1f4293d96 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -923,8 +923,8 @@ checkValidInstance ctxt hs_type ty -- The location of the "head" of the instance head_loc = case hs_type of - L _ (HsForAllTy _ _ _ (L loc _)) -> loc - L loc _ -> loc + L _ (HsForAllTy _ _ _ _ (L loc _)) -> loc + L loc _ -> loc \end{code} Note [Paterson conditions] diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 01ec26cae5..ca77adc95b 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -132,7 +132,7 @@ module Type ( pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, - TyPrec(..), maybeParen, + TyPrec(..), maybeParen, pprSigmaTypeExtraCts, -- * Tidying type related things up for printing tidyType, tidyTypes, @@ -1205,6 +1205,9 @@ eqType :: Type -> Type -> Bool -- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] eqType t1 t2 = isEqual $ cmpType t1 t2 +instance Eq Type where + (==) = eqType + eqTypeX :: RnEnv2 -> Type -> Type -> Bool eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 @@ -1631,7 +1634,7 @@ For the description of subkinding in GHC, see \begin{code} type MetaKindVar = TyVar -- invariant: MetaKindVar will always be a - -- TcTyVar with details MetaTv TauTv ... + -- TcTyVar with details MetaTv (TauTv ...) ... -- meta kind var constructors and functions are in TcType type SimpleKind = Kind diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index ef035bb3e1..c2f8a149b8 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -32,7 +32,7 @@ module TypeRep ( -- Pretty-printing pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, - pprTyThing, pprTyThingCategory, pprSigmaType, + pprTyThing, pprTyThingCategory, pprSigmaType, pprSigmaTypeExtraCts, pprTheta, pprForAll, pprUserForAll, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, suppressKinds, @@ -565,6 +565,10 @@ pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) p -- Eq j, Eq k, Eq l) => -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) +pprThetaArrowTyExtra :: ThetaType -> SDoc +pprThetaArrowTyExtra [] = text "_" <+> darrow +pprThetaArrowTyExtra preds = parens (fsep (punctuate comma xs)) <+> darrow + where xs = (map (ppr_type TopPrec) preds) ++ [text "_"] ------------------ instance Outputable Type where ppr ty = pprType ty @@ -598,9 +602,10 @@ ppr_type p fun_ty@(FunTy ty1 ty2) ppr_forall_type :: TyPrec -> Type -> SDoc ppr_forall_type p ty - = maybeParen p FunPrec $ ppr_sigma_type True ty + = maybeParen p FunPrec $ ppr_sigma_type True False ty -- True <=> we always print the foralls on *nested* quantifiers -- Opt_PrintExplicitForalls only affects top-level quantifiers + -- False <=> we don't print an extra-constraints wildcard ppr_tvar :: TyVar -> SDoc ppr_tvar tv -- Note [Infix type variables] @@ -613,13 +618,16 @@ ppr_tylit _ tl = StrTyLit s -> text (show s) ------------------- -ppr_sigma_type :: Bool -> Type -> SDoc --- Bool <=> Show the foralls unconditionally -ppr_sigma_type show_foralls_unconditionally ty +ppr_sigma_type :: Bool -> Bool -> Type -> SDoc +-- First Bool <=> Show the foralls unconditionally +-- Second Bool <=> Show an extra-constraints wildcard +ppr_sigma_type show_foralls_unconditionally extra_cts ty = sep [ if show_foralls_unconditionally then pprForAll tvs else pprUserForAll tvs - , pprThetaArrowTy ctxt + , if extra_cts + then pprThetaArrowTyExtra ctxt + else pprThetaArrowTy ctxt , pprType tau ] where (tvs, rho) = split1 [] ty @@ -632,7 +640,10 @@ ppr_sigma_type show_foralls_unconditionally ty split2 ps ty = (reverse ps, ty) pprSigmaType :: Type -> SDoc -pprSigmaType ty = ppr_sigma_type False ty +pprSigmaType ty = ppr_sigma_type False False ty + +pprSigmaTypeExtraCts :: Bool -> Type -> SDoc +pprSigmaTypeExtraCts = ppr_sigma_type False pprUserForAll :: [TyVar] -> SDoc -- Print a user-level forall; see Note [WHen to print foralls] diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 56ebcd3f0a..9ddd2710c5 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1056,6 +1056,12 @@ <entry><option>-XNoNamedFieldPuns</option></entry> </row> <row> + <entry><option>-XNamedWildcards</option></entry> + <entry>Enable <link linkend="named-wildcards">named wildcards</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoNamedWildcards</option></entry> + </row> + <row> <entry><option>-XNegativeLiterals</option></entry> <entry>Enable support for <link linkend="negative-literals">negative literals</link>.</entry> <entry>dynamic</entry> @@ -1120,6 +1126,12 @@ <entry><option>-XNoParallelListComp</option></entry> </row> <row> + <entry><option>-XPartialTypeSignatures</option></entry> + <entry>Enable <link linkend="partial-type-signatures">partial type signatures</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoPartialTypeSignatures</option></entry> + </row> + <row> <entry><option>-XPatternGuards</option></entry> <entry>Enable <link linkend="pattern-guards">pattern guards</link>.</entry> <entry>dynamic</entry> @@ -1652,6 +1664,19 @@ <entry><option>-fno-warn-typed-holes</option></entry> </row> + <row> + <entry><option>-fwarn-partial-type-signatures</option></entry> + <entry> + warn about holes in partial type signatures when + <option>-XPartialTypesignatures</option> is enabled. Not + applicable when <option>-XPartialTypesignatures</option> is not + enabled, in which case errors are generated for such holes. + See <xref linkend="partial-type-signatures"/>. + </entry> + <entry>dynamic</entry> + <entry><option>-fno-warn-partial-type-signatures</option></entry> + </row> + </tbody> </tgroup> </informaltable> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 5ed99ba5d3..586b31d853 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -8530,6 +8530,293 @@ This ensures that an unbound identifier is never reported with a too polymorphic </para> </sect1> +<!-- ==================== Partial Type Signatures ================= --> + +<sect1 id="partial-type-signatures"> +<title>Partial Type Signatures</title> + +<para> +A partial type signature is a type signature containing special placeholders +written with a leading underscore (e.g., "<literal>_</literal>", +"<literal>_foo</literal>", "<literal>_bar</literal>") called +<emphasis>wildcards</emphasis>. Partial type signatures are to type signatures +what <xref linkend="typed-holes"/> are to expressions. During compilation these +wildcards or holes will generate an error message that describes which type +was inferred at the hole's location, and information about the origin of any +free type variables. GHC reports such error messages by default.</para> + +<para> +Unlike <xref linkend="typed-holes"/>, which make the program incomplete and +will generate errors when they are evaluated, this needn't be the case for +holes in type signatures. The type checker is capable (in most cases) of +type-checking a binding with or without a type signature. A partial type +signature bridges the gap between the two extremes, the programmer can choose +which parts of a type to annotate and which to leave over to the type-checker +to infer. +</para> + +<para> +By default, the type-checker will report an error message for each hole in a +partial type signature, informing the programmer of the inferred type. When +the <option>-XPartialTypeSignatures</option> flag is enabled, the type-checker +will accept the inferred type for each hole, generating warnings instead of +errors. Additionally, these warnings can be silenced with the +<option>-fno-warn-partial-type-signatures</option> flag. +</para> + +<sect2 id="pts-syntax"> +<title>Syntax</title> + +<para> +A (partial) type signature has the following form: <literal>forall a b .. . +(C1, C2, ..) => tau</literal>. It consists of three parts: +</para> + +<itemizedlist> + <listitem>The type variables: <literal>a b ..</literal></listitem> + <listitem>The constraints: <literal>(C1, C2, ..)</literal></listitem> + <listitem>The (mono)type: <literal>tau</literal></listitem> +</itemizedlist> + +<para> +We distinguish three kinds of wildcards. +</para> + +<sect3 id="type-wildcards"> +<title>Type Wildcards</title> +<para> +Wildcards occurring within the monotype (tau) part of the type signature are +<emphasis>type wildcards</emphasis> ("type" is often omitted as this is the +default kind of wildcard). Type wildcards can be instantiated to any monotype +like <literal>Bool</literal> or <literal>Maybe [Bool]</literal>, including +functions and higher-kinded types like <literal>(Int -> Bool)</literal> or +<literal>Maybe</literal>. +</para> +<programlisting> +not' :: Bool -> _ +not' x = not x +-- Inferred: Bool -> Bool + +maybools :: _ +maybools = Just [True] +-- Inferred: Maybe [Bool] + +just1 :: _ Int +just1 = Just 1 +-- Inferred: Maybe Int + +filterInt :: _ -> _ -> [Int] +filterInt = filter -- has type forall a. (a -> Bool) -> [a] -> [a] +-- Inferred: (Int -> Bool) -> [Int] -> [Int] +</programlisting> + +<para> +For instance, the first wildcard in the type signature <literal>not'</literal> +would produce the following error message: +</para> +<programlisting> +Test.hs:4:17: + Found hole ‘_’ with type: Bool + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘not'’: Bool -> _ +</programlisting> + +<para> +When a wildcard is not instantiated to a monotype, it will be generalised +over, i.e. replaced by a fresh type variable (of which the name will often +start with <literal>w_</literal>), e.g. +</para> +<programlisting> +foo :: _ -> _ +foo x = x +-- Inferred: forall w_. w_ -> w_ + +filter' :: _ +filter' = filter -- has type forall a. (a -> Bool) -> [a] -> [a] +-- Inferred: (a -> Bool) -> [a] -> [a] +</programlisting> +</sect3> + +<sect3 id="named-wildcards"> +<title>Named Wildcards</title> +<para> +Type wildcards can also be named by giving the underscore an identifier as +suffix, i.e. <literal>_a</literal>. These are called <emphasis>named +wildcards</emphasis>. All occurrences of the same named wildcard within one +type signature will unify to the same type. For example: +</para> +<programlisting> +f :: _x -> _x +f ('c', y) = ('d', error "Urk") +-- Inferred: forall t. (Char, t) -> (Char, t) +</programlisting> + +<para> +The named wildcard forces the argument and result types to be the same. +Lacking a signature, GHC would have inferred <literal>forall a b. (Char, a) -> +(Char, b)</literal>. A named wildcard can be mentioned in constraints, +provided it also occurs in the monotype part of the type signature to make +sure that it unifies with something: +</para> + +<programlisting> +somethingShowable :: Show _x => _x -> _ +somethingShowable x = show x +-- Inferred type: Show w_x => w_x -> String + +somethingShowable' :: Show _x => _x -> _ +somethingShowable' x = show (not x) +-- Inferred type: Bool -> String +</programlisting> + +<para> +Besides an extra-constraints wildcard (see <xref +linkend="extra-constraints-wildcard"/>), only named wildcards can occur in the +constraints, e.g. the <literal>_x</literal> in <literal>Show _x</literal>. +</para> + +<para> +Named wildcards <emphasis>should not be confused with type +variables</emphasis>. Even though syntactically similar, named wildcards can +unify with monotypes as well as be generalised over (and behave as type +variables).</para> + +<para> +In the first example above, <literal>_x</literal> is generalised over (and is +effectively replaced by a fresh type variable <literal>w_x</literal>). In the +second example, <literal>_x</literal> is unified with the +<literal>Bool</literal> type, and as <literal>Bool</literal> implements the +<literal>Show</literal> type class, the constraint <literal>Show +Bool</literal> can be simplified away. +</para> + +<para> +By default, GHC (as the Haskell 2010 standard prescribes) parses identifiers +starting with an underscore in a type as type variables. To treat them as +named wildcards, the <option>-XNamedWildcards</option> flag should be enabled. +The example below demonstrated the effect. +</para> + +<programlisting> +foo :: _a -> _a +foo _ = False +</programlisting> + +<para> +Compiling this program without enabling <option>-XNamedWildcards</option> +produces the following error message complaining about the type variable +<literal>_a</literal> no matching the actual type <literal>Bool</literal>. +</para> + +<programlisting> +Test.hs:5:9: + Couldn't match expected type ‘_a’ with actual type ‘Bool’ + ‘_a’ is a rigid type variable bound by + the type signature for foo :: _a -> _a at Test.hs:4:8 + Relevant bindings include foo :: _a -> _a (bound at Test.hs:4:1) + In the expression: False + In an equation for ‘foo’: foo _ = False +</programlisting> + +<para> +Compiling this program with <option>-XNamedWildcards</option> enabled produces +the following error message reporting the inferred type of the named wildcard +<literal>_a</literal>. +</para> + +<programlisting> +Test.hs:4:8: Warning: + Found hole ‘_a’ with type: Bool + In the type signature for ‘foo’: _a -> _a +</programlisting> +</sect3> + +<sect3 id="extra-constraints-wildcard"> +<title>Extra-Constraints Wildcard</title> + +<para> +The third kind of wildcard is the <emphasis>extra-constraints +wildcard</emphasis>. The presence of an extra-constraints wildcard indicates +that an arbitrary number of extra constraints may be inferred during type +checking and will be added to the type signature. In the example below, the +extra-constraints wildcard is used to infer three extra constraints. +</para> + +<programlisting> +arbitCs :: _ => a -> String +arbitCs x = show (succ x) ++ show (x == x) +-- Inferred: +-- forall a. (Enum a, Eq a, Show a) => a -> String +-- Error: +Test.hs:5:12: + Found hole ‘_’ with inferred constraints: (Enum a, Eq a, Show a) + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘arbitCs’: _ => a -> String +</programlisting> + +<para> +An extra-constraints wildcard shouldn't prevent the programmer from already +listing the constraints he knows or wants to annotate, e.g. +</para> + +<programlisting> +-- Also a correct partial type signature: +arbitCs' :: (Enum a, _) => a -> String +arbitCs' x = arbitCs x +-- Inferred: +-- forall a. (Enum a, Show a, Eq a) => a -> String +-- Error: +Test.hs:9:22: + Found hole ‘_’ with inferred constraints: (Eq a, Show a) + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘arbitCs'’: (Enum a, _) => a -> String +</programlisting> + +<para> +An extra-constraints wildcard can also lead to zero extra constraints to be +inferred, e.g. +</para> + +<programlisting> +noCs :: _ => String +noCs = "noCs" +-- Inferred: String +-- Error: +Test.hs:13:9: + Found hole ‘_’ with inferred constraints: () + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘noCs’: _ => String +</programlisting> + +<para> +As a single extra-constraints wildcard is enough to infer any number of +constraints, only one is allowed in a type signature and it should come last +in the list of constraints. +</para> + +<para> +Extra-constraints wildcards cannot be named. +</para> + +</sect3> +</sect2> + +<sect2 id="pts-where"> +<title>Where can they occur?</title> + +<para> +Partial type signatures are allowed for bindings, pattern and expression signatures. +In all other contexts, e.g. type class or type family declarations, they are disallowed. +In the following example a wildcard is used in each of the three possible contexts. +</para> +<programlisting> +{-# LANGUAGE ScopedTypeVariables #-} +foo :: _ +foo (x :: _) = (x :: _) +-- Inferred: forall w_. w_ -> w_ +</programlisting> +</sect2> +</sect1> <!-- ==================== Deferring type errors ================= --> <sect1 id="defer-type-errors"> diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 309be8cf23..396af6cd06 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1178,6 +1178,24 @@ test.hs:(5,4)-(6,7): </varlistentry> <varlistentry> + <term><option>-fwarn-partial-type-signatures</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-partial-type-signatures</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <para> + Determines whether the compiler reports holes in partial type + signatures as warnings. Has no effect unless + <option>-XPartialTypeSignatures</option> is enabled, which + controls whether errors should be generated for holes in types + or not. See <xref linkend="partial-type-signatures"/>. + </para> + + <para>This warning is on by default.</para> + </listitem> + </varlistentry> + + <varlistentry> <term><option>-fhelpful-errors</option>:</term> <listitem> <indexterm><primary><option>-fhelpful-errors</option></primary> diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index f8b2f98c66..320238d865 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -35,7 +35,9 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRuleTransitional", "DeriveAnyClass", "JavaScriptFFI", - "PatternSynonyms"] + "PatternSynonyms", + "PartialTypeSignatures", + "NamedWildcards"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", diff --git a/testsuite/tests/partial-sigs/Makefile b/testsuite/tests/partial-sigs/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/partial-sigs/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/partial-sigs/should_compile/ADT.hs b/testsuite/tests/partial-sigs/should_compile/ADT.hs new file mode 100644 index 0000000000..476bf55611 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ADT.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ADT where + +data Foo x y z = Foo x y z + +bar :: Int -> _ Int +bar x = Foo True () x diff --git a/testsuite/tests/partial-sigs/should_compile/ADT.stderr b/testsuite/tests/partial-sigs/should_compile/ADT.stderr new file mode 100644 index 0000000000..74b1ae18f9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ADT.stderr @@ -0,0 +1,9 @@ +TYPE SIGNATURES + bar :: Int -> Foo Bool () Int +TYPE CONSTRUCTORS + data Foo x y z = Foo x y z + Promotable +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr1.hs b/testsuite/tests/partial-sigs/should_compile/AddAndOr1.hs new file mode 100644 index 0000000000..39b7fe1dc5 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr1.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr1 where + +addAndOr1 :: _ +addAndOr1 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr new file mode 100644 index 0000000000..b0952b4d5e --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + addAndOr1 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr2.hs b/testsuite/tests/partial-sigs/should_compile/AddAndOr2.hs new file mode 100644 index 0000000000..767c2e6771 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr2 where + +addAndOr2 :: _ -> _ +addAndOr2 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr new file mode 100644 index 0000000000..f902a80073 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + addAndOr2 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr3.hs b/testsuite/tests/partial-sigs/should_compile/AddAndOr3.hs new file mode 100644 index 0000000000..a1486bc1b2 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr3.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr3 where + +addAndOr3 :: _ -> _ -> _ +addAndOr3 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr new file mode 100644 index 0000000000..f68e6ef50d --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + addAndOr3 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr4.hs b/testsuite/tests/partial-sigs/should_compile/AddAndOr4.hs new file mode 100644 index 0000000000..6afba46498 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr4.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr4 where + +addAndOr4 :: (_ _ _) -> (_ _ _) -> (_ _ _) +addAndOr4 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr new file mode 100644 index 0000000000..be7cc05f1b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + addAndOr4 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr5.hs b/testsuite/tests/partial-sigs/should_compile/AddAndOr5.hs new file mode 100644 index 0000000000..5de904adf8 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr5.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr5 where + +addAndOr5 :: (_, _) -> (_, _) -> (_, _) +addAndOr5 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr new file mode 100644 index 0000000000..8e6699443f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + addAndOr5 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr6.hs b/testsuite/tests/partial-sigs/should_compile/AddAndOr6.hs new file mode 100644 index 0000000000..79ceee27e7 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr6.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr6 where + +addAndOr6 :: (Int, _) -> (Bool, _) -> (_ Int Bool) +addAndOr6 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr b/testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr new file mode 100644 index 0000000000..ec1703a535 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + addAndOr6 :: (Int, Bool) -> (Bool, Int) -> (Int, Bool) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/BoolToBool.hs b/testsuite/tests/partial-sigs/should_compile/BoolToBool.hs new file mode 100644 index 0000000000..f27f8e04dd --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/BoolToBool.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module BoolToBool where + +bar :: _ -> _ +bar x = not x diff --git a/testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr b/testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr new file mode 100644 index 0000000000..3d8f949fd0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bar :: Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.hs b/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.hs new file mode 100644 index 0000000000..23223b720f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE MonomorphismRestriction #-} +module Defaulting1MROn where + +alpha :: _ +alpha = 3 diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr new file mode 100644 index 0000000000..fbcaddebfc --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + alpha :: Integer +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.hs b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.hs new file mode 100644 index 0000000000..f192c02b05 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module Defaulting2MROff where + +bravo :: _ => _ +bravo = 3 diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr new file mode 100644 index 0000000000..fb95845970 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bravo :: forall w_. Num w_ => w_ +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.hs b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.hs new file mode 100644 index 0000000000..6afcad1186 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE MonomorphismRestriction #-} +module Defaulting2MROn where + +bravo :: _ => _ +bravo = 3 diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr new file mode 100644 index 0000000000..9fda9ec815 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bravo :: Integer +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Either.hs b/testsuite/tests/partial-sigs/should_compile/Either.hs new file mode 100644 index 0000000000..39337f57de --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Either.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module Either where + +barry :: _a -> (_b _a, _b _) +barry x = (Left "x", Right x) diff --git a/testsuite/tests/partial-sigs/should_compile/Either.stderr b/testsuite/tests/partial-sigs/should_compile/Either.stderr new file mode 100644 index 0000000000..bff0e846eb --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Either.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + barry :: forall w_a. w_a -> (Either [Char] w_a, Either [Char] w_a) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.hs b/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.hs new file mode 100644 index 0000000000..170af6462d --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, TypeFamilies #-} +module EqualityConstraint where + +foo :: a ~ Bool => (a, _) +foo = (True, False) diff --git a/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr b/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr new file mode 100644 index 0000000000..269a6116fb --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: forall a. a ~ Bool => (a, Bool) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-0.5.1.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Every.hs b/testsuite/tests/partial-sigs/should_compile/Every.hs new file mode 100644 index 0000000000..3c82fa2aab --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Every.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module Every where + +every :: _ -> _ -> Bool +every _ [] = True +every p (x:xs) = p x && every p xs diff --git a/testsuite/tests/partial-sigs/should_compile/Every.stderr b/testsuite/tests/partial-sigs/should_compile/Every.stderr new file mode 100644 index 0000000000..90bcb57471 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Every.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + every :: forall t. (t -> Bool) -> [t] -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/EveryNamed.hs b/testsuite/tests/partial-sigs/should_compile/EveryNamed.hs new file mode 100644 index 0000000000..3d91e3a613 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/EveryNamed.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module EveryNamed where + +every :: (_a -> Bool) -> [_a] -> Bool +every _ [] = True +every p (x:xs) = p x && every p xs diff --git a/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr b/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr new file mode 100644 index 0000000000..ce7c7a3d81 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + every :: forall w_a. (w_a -> Bool) -> [w_a] -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExpressionSig.hs b/testsuite/tests/partial-sigs/should_compile/ExpressionSig.hs new file mode 100644 index 0000000000..bce424a69f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExpressionSig.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExpressionSig where + +bar :: Bool -> Bool +bar x = (x :: _) diff --git a/testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr b/testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr new file mode 100644 index 0000000000..3d8f949fd0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bar :: Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.hs b/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.hs new file mode 100644 index 0000000000..3be7bea64d --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module ExpressionSigNamed where + +bar :: _a -> _a +bar True = (False :: _a) +bar False = (True :: _a) diff --git a/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr b/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr new file mode 100644 index 0000000000..3d8f949fd0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bar :: Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.hs b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.hs new file mode 100644 index 0000000000..f6c6a915ca --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraints1 where + +arbitCs1 :: _ => a -> String +arbitCs1 x = show (succ x) ++ show (x == x) + +arbitCs2 :: (Show a, _) => a -> String +arbitCs2 x = arbitCs1 x + +arbitCs3 :: (Show a, Enum a, _) => a -> String +arbitCs3 x = arbitCs1 x + +arbitCs4 :: (Eq a, _) => a -> String +arbitCs4 x = arbitCs1 x + +arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String +arbitCs5 x = arbitCs1 x diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr new file mode 100644 index 0000000000..15eb30d1bf --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr @@ -0,0 +1,11 @@ +TYPE SIGNATURES + arbitCs1 :: forall a. (Enum a, Eq a, Show a) => a -> String + arbitCs2 :: forall a. (Show a, Enum a, Eq a) => a -> String + arbitCs3 :: forall a. (Show a, Enum a, Eq a) => a -> String + arbitCs4 :: forall a. (Eq a, Enum a, Show a) => a -> String + arbitCs5 :: forall a. (Eq a, Enum a, Show a) => a -> String +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.hs b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.hs new file mode 100644 index 0000000000..168d4db281 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE GADTs #-} +module ExtraConstraints2 where + +foo :: _ => String +foo = "x" + +-- No extra constraints diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr new file mode 100644 index 0000000000..8c28c5b93b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: String +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.hs b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.hs new file mode 100644 index 0000000000..56b9f356da --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module ExtraConstraints3 where + +import qualified Prelude as P + +import Prelude (Bool, Bounded, Char, Either, Enum, Eq, FilePath, Floating, + Fractional, Functor, IO, IOError, Int, Integer, Integral, + Maybe, Monad, Num, Ord, Ordering, Rational, Read, ReadS, Real, + RealFloat, RealFrac, Show, ShowS, String) + +-- Proof by enumeration! jk :p +-- All of Prelude typechecks given the dummy type signature `_ => _`, +-- which is the same as omitting the type signature entirely. + +(!!) :: _ => _ +(!!) = (P.!!) +($!) :: _ => _ +($!) = (P.$!) +($) :: _ => _ +($) = (P.$) +(&&) :: _ => _ +(&&) = (P.&&) +(*) :: _ => _ +(*) = (P.*) +(**) :: _ => _ +(**) = (P.**) +(+) :: _ => _ +(+) = (P.+) +(++) :: _ => _ +(++) = (P.++) +(-) :: _ => _ +(-) = (P.-) +(.) :: _ => _ +(.) = (P..) +(/) :: _ => _ +(/) = (P./) +(/=) :: _ => _ +(/=) = (P./=) +(<) :: _ => _ +(<) = (P.<) +(<=) :: _ => _ +(<=) = (P.<=) +(=<<) :: _ => _ +(=<<) = (P.=<<) +(==) :: _ => _ +(==) = (P.==) +(>) :: _ => _ +(>) = (P.>) +(>=) :: _ => _ +(>=) = (P.>=) +(>>) :: _ => _ +(>>) = (P.>>) +(>>=) :: _ => _ +(>>=) = (P.>>=) +(^) :: _ => _ +(^) = (P.^) +(^^) :: _ => _ +(^^) = (P.^^) +(||) :: _ => _ +(||) = (P.||) +abs :: _ => _ +abs = P.abs +acos :: _ => _ +acos = P.acos +acosh :: _ => _ +acosh = P.acosh +all :: _ => _ +all = P.all +and :: _ => _ +and = P.and +any :: _ => _ +any = P.any +appendFile :: _ => _ +appendFile = P.appendFile +asTypeOf :: _ => _ +asTypeOf = P.asTypeOf +asin :: _ => _ +asin = P.asin +asinh :: _ => _ +asinh = P.asinh +atan :: _ => _ +atan = P.atan +atan2 :: _ => _ +atan2 = P.atan2 +atanh :: _ => _ +atanh = P.atanh +break :: _ => _ +break = P.break +ceiling :: _ => _ +ceiling = P.ceiling +compare :: _ => _ +compare = P.compare +concat :: _ => _ +concat = P.concat +concatMap :: _ => _ +concatMap = P.concatMap +const :: _ => _ +const = P.const +cos :: _ => _ +cos = P.cos +cosh :: _ => _ +cosh = P.cosh +curry :: _ => _ +curry = P.curry +cycle :: _ => _ +cycle = P.cycle +decodeFloat :: _ => _ +decodeFloat = P.decodeFloat +div :: _ => _ +div = P.div +divMod :: _ => _ +divMod = P.divMod +drop :: _ => _ +drop = P.drop +dropWhile :: _ => _ +dropWhile = P.dropWhile +either :: _ => _ +either = P.either +elem :: _ => _ +elem = P.elem +encodeFloat :: _ => _ +encodeFloat = P.encodeFloat +enumFrom :: _ => _ +enumFrom = P.enumFrom +enumFromThen :: _ => _ +enumFromThen = P.enumFromThen +enumFromThenTo :: _ => _ +enumFromThenTo = P.enumFromThenTo +enumFromTo :: _ => _ +enumFromTo = P.enumFromTo +error :: _ => _ +error = P.error +even :: _ => _ +even = P.even +exp :: _ => _ +exp = P.exp +exponent :: _ => _ +exponent = P.exponent +fail :: _ => _ +fail = P.fail +filter :: _ => _ +filter = P.filter +flip :: _ => _ +flip = P.flip +floatDigits :: _ => _ +floatDigits = P.floatDigits +floatRadix :: _ => _ +floatRadix = P.floatRadix +floatRange :: _ => _ +floatRange = P.floatRange +floor :: _ => _ +floor = P.floor +fmap :: _ => _ +fmap = P.fmap +foldl :: _ => _ +foldl = P.foldl +foldl1 :: _ => _ +foldl1 = P.foldl1 +foldr :: _ => _ +foldr = P.foldr +foldr1 :: _ => _ +foldr1 = P.foldr1 +fromEnum :: _ => _ +fromEnum = P.fromEnum +fromInteger :: _ => _ +fromInteger = P.fromInteger +fromIntegral :: _ => _ +fromIntegral = P.fromIntegral +fromRational :: _ => _ +fromRational = P.fromRational +fst :: _ => _ +fst = P.fst +gcd :: _ => _ +gcd = P.gcd +getChar :: _ => _ +getChar = P.getChar +getContents :: _ => _ +getContents = P.getContents +getLine :: _ => _ +getLine = P.getLine +head :: _ => _ +head = P.head +id :: _ => _ +id = P.id +init :: _ => _ +init = P.init +interact :: _ => _ +interact = P.interact +ioError :: _ => _ +ioError = P.ioError +isDenormalized :: _ => _ +isDenormalized = P.isDenormalized +isIEEE :: _ => _ +isIEEE = P.isIEEE +isInfinite :: _ => _ +isInfinite = P.isInfinite +isNaN :: _ => _ +isNaN = P.isNaN +isNegativeZero :: _ => _ +isNegativeZero = P.isNegativeZero +iterate :: _ => _ +iterate = P.iterate +last :: _ => _ +last = P.last +lcm :: _ => _ +lcm = P.lcm +length :: _ => _ +length = P.length +lex :: _ => _ +lex = P.lex +lines :: _ => _ +lines = P.lines +log :: _ => _ +log = P.log +logBase :: _ => _ +logBase = P.logBase +lookup :: _ => _ +lookup = P.lookup +map :: _ => _ +map = P.map +mapM :: _ => _ +mapM = P.mapM +mapM_ :: _ => _ +mapM_ = P.mapM_ +max :: _ => _ +max = P.max +maxBound :: _ => _ +maxBound = P.maxBound +maximum :: _ => _ +maximum = P.maximum +maybe :: _ => _ +maybe = P.maybe +min :: _ => _ +min = P.min +minBound :: _ => _ +minBound = P.minBound +minimum :: _ => _ +minimum = P.minimum +mod :: _ => _ +mod = P.mod +negate :: _ => _ +negate = P.negate +not :: _ => _ +not = P.not +notElem :: _ => _ +notElem = P.notElem +null :: _ => _ +null = P.null +odd :: _ => _ +odd = P.odd +or :: _ => _ +or = P.or +otherwise :: _ => _ +otherwise = P.otherwise +pi :: _ => _ +pi = P.pi +pred :: _ => _ +pred = P.pred +print :: _ => _ +print = P.print +product :: _ => _ +product = P.product +properFraction :: _ => _ +properFraction = P.properFraction +putChar :: _ => _ +putChar = P.putChar +putStr :: _ => _ +putStr = P.putStr +putStrLn :: _ => _ +putStrLn = P.putStrLn +quot :: _ => _ +quot = P.quot +quotRem :: _ => _ +quotRem = P.quotRem +read :: _ => _ +read = P.read +readFile :: _ => _ +readFile = P.readFile +readIO :: _ => _ +readIO = P.readIO +readList :: _ => _ +readList = P.readList +readLn :: _ => _ +readLn = P.readLn +readParen :: _ => _ +readParen = P.readParen +reads :: _ => _ +reads = P.reads +readsPrec :: _ => _ +readsPrec = P.readsPrec +realToFrac :: _ => _ +realToFrac = P.realToFrac +recip :: _ => _ +recip = P.recip +rem :: _ => _ +rem = P.rem +repeat :: _ => _ +repeat = P.repeat +replicate :: _ => _ +replicate = P.replicate +return :: _ => _ +return = P.return +reverse :: _ => _ +reverse = P.reverse +round :: _ => _ +round = P.round +scaleFloat :: _ => _ +scaleFloat = P.scaleFloat +scanl :: _ => _ +scanl = P.scanl +scanl1 :: _ => _ +scanl1 = P.scanl1 +scanr :: _ => _ +scanr = P.scanr +scanr1 :: _ => _ +scanr1 = P.scanr1 +seq :: _ => _ +seq = P.seq +sequence :: _ => _ +sequence = P.sequence +sequence_ :: _ => _ +sequence_ = P.sequence_ +show :: _ => _ +show = P.show +showChar :: _ => _ +showChar = P.showChar +showList :: _ => _ +showList = P.showList +showParen :: _ => _ +showParen = P.showParen +showString :: _ => _ +showString = P.showString +shows :: _ => _ +shows = P.shows +showsPrec :: _ => _ +showsPrec = P.showsPrec +significand :: _ => _ +significand = P.significand +signum :: _ => _ +signum = P.signum +sin :: _ => _ +sin = P.sin +sinh :: _ => _ +sinh = P.sinh +snd :: _ => _ +snd = P.snd +span :: _ => _ +span = P.span +splitAt :: _ => _ +splitAt = P.splitAt +sqrt :: _ => _ +sqrt = P.sqrt +subtract :: _ => _ +subtract = P.subtract +succ :: _ => _ +succ = P.succ +sum :: _ => _ +sum = P.sum +tail :: _ => _ +tail = P.tail +take :: _ => _ +take = P.take +takeWhile :: _ => _ +takeWhile = P.takeWhile +tan :: _ => _ +tan = P.tan +tanh :: _ => _ +tanh = P.tanh +toEnum :: _ => _ +toEnum = P.toEnum +toInteger :: _ => _ +toInteger = P.toInteger +toRational :: _ => _ +toRational = P.toRational +truncate :: _ => _ +truncate = P.truncate +uncurry :: _ => _ +uncurry = P.uncurry +undefined :: _ => _ +undefined = P.undefined +unlines :: _ => _ +unlines = P.unlines +until :: _ => _ +until = P.until +unwords :: _ => _ +unwords = P.unwords +unzip :: _ => _ +unzip = P.unzip +unzip3 :: _ => _ +unzip3 = P.unzip3 +userError :: _ => _ +userError = P.userError +words :: _ => _ +words = P.words +writeFile :: _ => _ +writeFile = P.writeFile +zip :: _ => _ +zip = P.zip +zip3 :: _ => _ +zip3 = P.zip3 +zipWith :: _ => _ +zipWith = P.zipWith +zipWith3 :: _ => _ +zipWith3 = P.zipWith3 diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr new file mode 100644 index 0000000000..f4df3cb141 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr @@ -0,0 +1,234 @@ +TYPE SIGNATURES + !! :: forall a. [a] -> Int -> a + $ :: forall a b. (a -> b) -> a -> b + $! :: forall a b. (a -> b) -> a -> b + && :: Bool -> Bool -> Bool + * :: forall a. Num a => a -> a -> a + ** :: forall a. Floating a => a -> a -> a + + :: forall a. Num a => a -> a -> a + ++ :: forall a. [a] -> [a] -> [a] + - :: forall a. Num a => a -> a -> a + . :: forall b c a. (b -> c) -> (a -> b) -> a -> c + / :: forall a. Fractional a => a -> a -> a + /= :: forall a. Eq a => a -> a -> Bool + < :: forall a. Ord a => a -> a -> Bool + <= :: forall a. Ord a => a -> a -> Bool + =<< :: + forall a (m :: * -> *) b. Monad m => (a -> m b) -> m a -> m b + == :: forall a. Eq a => a -> a -> Bool + > :: forall a. Ord a => a -> a -> Bool + >= :: forall a. Ord a => a -> a -> Bool + >> :: forall (m :: * -> *) a b. Monad m => m a -> m b -> m b + >>= :: + forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b + ^ :: forall a b. (Integral b, Num a) => a -> b -> a + ^^ :: forall a b. (Fractional a, Integral b) => a -> b -> a + abs :: forall a. Num a => a -> a + acos :: forall a. Floating a => a -> a + acosh :: forall a. Floating a => a -> a + all :: + forall a (t :: * -> *). P.Foldable t => (a -> Bool) -> t a -> Bool + and :: forall (t :: * -> *). P.Foldable t => t Bool -> Bool + any :: + forall a (t :: * -> *). P.Foldable t => (a -> Bool) -> t a -> Bool + appendFile :: FilePath -> String -> IO () + asTypeOf :: forall a. a -> a -> a + asin :: forall a. Floating a => a -> a + asinh :: forall a. Floating a => a -> a + atan :: forall a. Floating a => a -> a + atan2 :: forall a. RealFloat a => a -> a -> a + atanh :: forall a. Floating a => a -> a + break :: forall a. (a -> Bool) -> [a] -> ([a], [a]) + ceiling :: forall a b. (Integral b, RealFrac a) => a -> b + compare :: forall a. Ord a => a -> a -> Ordering + concat :: forall (t :: * -> *) a. P.Foldable t => t [a] -> [a] + concatMap :: + forall a b (t :: * -> *). P.Foldable t => (a -> [b]) -> t a -> [b] + const :: forall a b. a -> b -> a + cos :: forall a. Floating a => a -> a + cosh :: forall a. Floating a => a -> a + curry :: forall a b c. ((a, b) -> c) -> a -> b -> c + cycle :: forall a. [a] -> [a] + decodeFloat :: forall a. RealFloat a => a -> (Integer, Int) + div :: forall a. Integral a => a -> a -> a + divMod :: forall a. Integral a => a -> a -> (a, a) + drop :: forall a. Int -> [a] -> [a] + dropWhile :: forall a. (a -> Bool) -> [a] -> [a] + either :: forall a c b. (a -> c) -> (b -> c) -> Either a b -> c + elem :: + forall (t :: * -> *) a. (Eq a, P.Foldable t) => a -> t a -> Bool + encodeFloat :: forall a. RealFloat a => Integer -> Int -> a + enumFrom :: forall a. Enum a => a -> [a] + enumFromThen :: forall a. Enum a => a -> a -> [a] + enumFromThenTo :: forall a. Enum a => a -> a -> a -> [a] + enumFromTo :: forall a. Enum a => a -> a -> [a] + error :: forall a. [Char] -> a + even :: forall a. Integral a => a -> Bool + exp :: forall a. Floating a => a -> a + exponent :: forall a. RealFloat a => a -> Int + fail :: forall (m :: * -> *) a. Monad m => String -> m a + filter :: forall a. (a -> Bool) -> [a] -> [a] + flip :: forall a b c. (a -> b -> c) -> b -> a -> c + floatDigits :: forall a. RealFloat a => a -> Int + floatRadix :: forall a. RealFloat a => a -> Integer + floatRange :: forall a. RealFloat a => a -> (Int, Int) + floor :: forall a b. (Integral b, RealFrac a) => a -> b + fmap :: + forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b + foldl :: + forall (t :: * -> *) b a. + P.Foldable t => + (b -> a -> b) -> b -> t a -> b + foldl1 :: + forall (t :: * -> *) a. P.Foldable t => (a -> a -> a) -> t a -> a + foldr :: + forall (t :: * -> *) a b. + P.Foldable t => + (a -> b -> b) -> b -> t a -> b + foldr1 :: + forall (t :: * -> *) a. P.Foldable t => (a -> a -> a) -> t a -> a + fromEnum :: forall a. Enum a => a -> Int + fromInteger :: forall a. Num a => Integer -> a + fromIntegral :: forall a b. (Integral a, Num b) => a -> b + fromRational :: forall a. Fractional a => Rational -> a + fst :: forall a b. (a, b) -> a + gcd :: forall a. Integral a => a -> a -> a + getChar :: IO Char + getContents :: IO String + getLine :: IO String + head :: forall a. [a] -> a + id :: forall a. a -> a + init :: forall a. [a] -> [a] + interact :: (String -> String) -> IO () + ioError :: forall a. IOError -> IO a + isDenormalized :: forall a. RealFloat a => a -> Bool + isIEEE :: forall a. RealFloat a => a -> Bool + isInfinite :: forall a. RealFloat a => a -> Bool + isNaN :: forall a. RealFloat a => a -> Bool + isNegativeZero :: forall a. RealFloat a => a -> Bool + iterate :: forall a. (a -> a) -> a -> [a] + last :: forall a. [a] -> a + lcm :: forall a. Integral a => a -> a -> a + length :: forall (t :: * -> *) a. P.Foldable t => t a -> Int + lex :: ReadS String + lines :: String -> [String] + log :: forall a. Floating a => a -> a + logBase :: forall a. Floating a => a -> a -> a + lookup :: forall a b. Eq a => a -> [(a, b)] -> Maybe b + map :: forall a b. (a -> b) -> [a] -> [b] + mapM :: + forall (t :: * -> *) a (m :: * -> *) b. + (Monad m, P.Traversable t) => + (a -> m b) -> t a -> m (t b) + mapM_ :: + forall a (m :: * -> *) b (t :: * -> *). + (Monad m, P.Foldable t) => + (a -> m b) -> t a -> m () + max :: forall a. Ord a => a -> a -> a + maxBound :: forall w_. Bounded w_ => w_ + maximum :: + forall (t :: * -> *) a. (Ord a, P.Foldable t) => t a -> a + maybe :: forall b a. b -> (a -> b) -> Maybe a -> b + min :: forall a. Ord a => a -> a -> a + minBound :: forall w_. Bounded w_ => w_ + minimum :: + forall (t :: * -> *) a. (Ord a, P.Foldable t) => t a -> a + mod :: forall a. Integral a => a -> a -> a + negate :: forall a. Num a => a -> a + not :: Bool -> Bool + notElem :: + forall a (t :: * -> *). (Eq a, P.Foldable t) => a -> t a -> Bool + null :: forall (t :: * -> *) a. P.Foldable t => t a -> Bool + odd :: forall a. Integral a => a -> Bool + or :: forall (t :: * -> *). P.Foldable t => t Bool -> Bool + otherwise :: Bool + pi :: forall w_. Floating w_ => w_ + pred :: forall a. Enum a => a -> a + print :: forall a. Show a => a -> IO () + product :: + forall (t :: * -> *) a. (Num a, P.Foldable t) => t a -> a + properFraction :: + forall a b. (Integral b, RealFrac a) => a -> (b, a) + putChar :: Char -> IO () + putStr :: String -> IO () + putStrLn :: String -> IO () + quot :: forall a. Integral a => a -> a -> a + quotRem :: forall a. Integral a => a -> a -> (a, a) + read :: forall a. Read a => String -> a + readFile :: FilePath -> IO String + readIO :: forall a. Read a => String -> IO a + readList :: forall a. Read a => ReadS [a] + readLn :: forall a. Read a => IO a + readParen :: forall a. Bool -> ReadS a -> ReadS a + reads :: forall a. Read a => ReadS a + readsPrec :: forall a. Read a => Int -> ReadS a + realToFrac :: forall a b. (Fractional b, Real a) => a -> b + recip :: forall a. Fractional a => a -> a + rem :: forall a. Integral a => a -> a -> a + repeat :: forall a. a -> [a] + replicate :: forall a. Int -> a -> [a] + return :: forall (m :: * -> *) a. Monad m => a -> m a + reverse :: forall a. [a] -> [a] + round :: forall a b. (Integral b, RealFrac a) => a -> b + scaleFloat :: forall a. RealFloat a => Int -> a -> a + scanl :: forall b a. (b -> a -> b) -> b -> [a] -> [b] + scanl1 :: forall a. (a -> a -> a) -> [a] -> [a] + scanr :: forall a b. (a -> b -> b) -> b -> [a] -> [b] + scanr1 :: forall a. (a -> a -> a) -> [a] -> [a] + seq :: forall a b. a -> b -> b + sequence :: + forall (t :: * -> *) (m :: * -> *) a. + (Monad m, P.Traversable t) => + t (m a) -> m (t a) + sequence_ :: + forall (t :: * -> *) (m :: * -> *) a. + (Monad m, P.Foldable t) => + t (m a) -> m () + show :: forall a. Show a => a -> String + showChar :: Char -> ShowS + showList :: forall a. Show a => [a] -> ShowS + showParen :: Bool -> ShowS -> ShowS + showString :: String -> ShowS + shows :: forall a. Show a => a -> ShowS + showsPrec :: forall a. Show a => Int -> a -> ShowS + significand :: forall a. RealFloat a => a -> a + signum :: forall a. Num a => a -> a + sin :: forall a. Floating a => a -> a + sinh :: forall a. Floating a => a -> a + snd :: forall a b. (a, b) -> b + span :: forall a. (a -> Bool) -> [a] -> ([a], [a]) + splitAt :: forall a. Int -> [a] -> ([a], [a]) + sqrt :: forall a. Floating a => a -> a + subtract :: forall a. Num a => a -> a -> a + succ :: forall a. Enum a => a -> a + sum :: forall (t :: * -> *) a. (Num a, P.Foldable t) => t a -> a + tail :: forall a. [a] -> [a] + take :: forall a. Int -> [a] -> [a] + takeWhile :: forall a. (a -> Bool) -> [a] -> [a] + tan :: forall a. Floating a => a -> a + tanh :: forall a. Floating a => a -> a + toEnum :: forall a. Enum a => Int -> a + toInteger :: forall a. Integral a => a -> Integer + toRational :: forall a. Real a => a -> Rational + truncate :: forall a b. (Integral b, RealFrac a) => a -> b + uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c + undefined :: forall w_. w_ + unlines :: [String] -> String + until :: forall a. (a -> Bool) -> (a -> a) -> a -> a + unwords :: [String] -> String + unzip :: forall a b. [(a, b)] -> ([a], [b]) + unzip3 :: forall a b c. [(a, b, c)] -> ([a], [b], [c]) + userError :: String -> IOError + words :: String -> [String] + writeFile :: FilePath -> String -> IO () + zip :: forall a b. [a] -> [b] -> [(a, b)] + zip3 :: forall a b c. [a] -> [b] -> [c] -> [(a, b, c)] + zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] + zipWith3 :: + forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] + || :: Bool -> Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.hs b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.hs new file mode 100644 index 0000000000..81fad840f7 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module ExtraNumAMROff where + +foo :: _ => a +foo = 3 diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr new file mode 100644 index 0000000000..6bb444ad36 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: forall a. Num a => a +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.hs b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.hs new file mode 100644 index 0000000000..e37fc962d0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE MonomorphismRestriction #-} +module ExtraNumAMROn where + +foo :: _ => a +foo = 3 diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr new file mode 100644 index 0000000000..e7866941c9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: forall a. Num a => a +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-0.5.1.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Forall1.hs b/testsuite/tests/partial-sigs/should_compile/Forall1.hs new file mode 100644 index 0000000000..c5fe2c77da --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Forall1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, ScopedTypeVariables #-} +module Forall1 where + +fall :: forall a. _ -> a +fall v = v diff --git a/testsuite/tests/partial-sigs/should_compile/Forall1.stderr b/testsuite/tests/partial-sigs/should_compile/Forall1.stderr new file mode 100644 index 0000000000..1af38e4a62 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Forall1.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + fall :: forall a. a -> a +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/GenNamed.hs b/testsuite/tests/partial-sigs/should_compile/GenNamed.hs new file mode 100644 index 0000000000..cd33483912 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/GenNamed.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module GenNamed where + +bar :: _a -> _a +bar x = not x diff --git a/testsuite/tests/partial-sigs/should_compile/GenNamed.stderr b/testsuite/tests/partial-sigs/should_compile/GenNamed.stderr new file mode 100644 index 0000000000..3d8f949fd0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/GenNamed.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bar :: Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/HigherRank1.hs b/testsuite/tests/partial-sigs/should_compile/HigherRank1.hs new file mode 100644 index 0000000000..18eb251a70 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/HigherRank1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} +module HigherRank1 where + +foo :: (forall a. [a] -> [a]) -> _ +foo x = (x [True, False], x ['a', 'b']) diff --git a/testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr b/testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr new file mode 100644 index 0000000000..1a3e436cac --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: (forall a. [a] -> [a]) -> ([Bool], [Char]) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/HigherRank2.hs b/testsuite/tests/partial-sigs/should_compile/HigherRank2.hs new file mode 100644 index 0000000000..b1c6516f9a --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/HigherRank2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} +module HigherRank2 where + +foo :: (forall a. [a] -> [a]) -> (_, _ _) +foo x = (x [True, False], x ['a', 'b']) diff --git a/testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr b/testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr new file mode 100644 index 0000000000..1a3e436cac --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: (forall a. [a] -> [a]) -> ([Bool], [Char]) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.hs b/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.hs new file mode 100644 index 0000000000..85d86f9734 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PartialTypeSignatures #-} +module LocalDefinitionBug where + +monoLoc :: forall a. a -> ((a, String), (a, _)) +monoLoc x = (g True , g False) + where + g :: t -> (a, String) + g _ = (x, "foo") + +-- Test case for (fixed) bug that previously generated the following error message: + +-- LocalDefinitionBug.hs:9:16: +-- GHC internal error: ‘a’ is not in scope during type checking, but it passed the renamer +-- tcl_env of environment: [alA :-> Type variable ‘_’ = _, +-- alC :-> Identifier[x::a, <NotTopLevel>], +-- alE :-> Type variable ‘t’ = t, +-- rjF :-> Identifier[monoLoc::a +-- -> ((a, String), (a, _)), <NotTopLevel>]] +-- In the type signature for ‘g’: g :: t -> (a, String) +-- In an equation for ‘monoLoc’: +-- monoLoc x +-- = (g True, g False) +-- where +-- g :: t -> (a, String) +-- g _ = (x, "foo") + + +-- Fixed by using tcExtendTyVarEnv2 instead of tcExtendTyVarEnv diff --git a/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr b/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr new file mode 100644 index 0000000000..9f99e17bfe --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + monoLoc :: forall a. a -> ((a, String), (a, String)) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Makefile b/testsuite/tests/partial-sigs/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/partial-sigs/should_compile/Meltdown.hs b/testsuite/tests/partial-sigs/should_compile/Meltdown.hs new file mode 100644 index 0000000000..1ead4032a8 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Meltdown.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE PartialTypeSignatures, ScopedTypeVariables, NamedWildcards #-} +module Meltdown where + +import Control.Applicative + +data NukeMonad a b c + +instance Functor (NukeMonad a b) where + fmap = undefined + +instance Applicative (NukeMonad a b) where + pure = undefined + (<*>) = undefined + +instance Monad (NukeMonad a b) where + return = undefined + (>>=) = undefined + + +isMeltdown :: NukeMonad param1 param2 Bool +isMeltdown = undefined + +unlessMeltdown :: _nm () -> _nm () +unlessMeltdown c = do m <- isMeltdown + if m then return () else c diff --git a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr new file mode 100644 index 0000000000..303f72a3ec --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr @@ -0,0 +1,18 @@ +TYPE SIGNATURES + isMeltdown :: forall param1 param2. NukeMonad param1 param2 Bool + unlessMeltdown :: + forall param1 param2. + NukeMonad param1 param2 () -> NukeMonad param1 param2 () +TYPE CONSTRUCTORS + type role NukeMonad phantom phantom phantom + data NukeMonad a b c + Promotable +COERCION AXIOMS +INSTANCES + instance Functor (NukeMonad a b) -- Defined at Meltdown.hs:8:10 + instance Applicative (NukeMonad a b) + -- Defined at Meltdown.hs:11:10 + instance Monad (NukeMonad a b) -- Defined at Meltdown.hs:15:10 +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.hs b/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.hs new file mode 100644 index 0000000000..7ccd3dba77 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module MonoLocalBinds where + +monoLoc :: forall a. a -> ((a, String), (a, String)) +monoLoc x = (g True , g 'v') + where + -- g :: b -> (a, String) -- #1 + g :: b -> (a, _) -- #2 + g y = (x, "foo") + +-- For #2, we should infer the same type as in #1. diff --git a/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr b/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr new file mode 100644 index 0000000000..5da503bfd9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + monoLoc :: forall a. a -> ((a, String), (a, String)) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-0.5.1.0] diff --git a/testsuite/tests/partial-sigs/should_compile/NamedTyVar.hs b/testsuite/tests/partial-sigs/should_compile/NamedTyVar.hs new file mode 100644 index 0000000000..e30cb7d064 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/NamedTyVar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module NamedTyVar where + +foo :: (_a, b) -> (a, _b) +foo (x, y) = (x, y) diff --git a/testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr b/testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr new file mode 100644 index 0000000000..e6c007a602 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: forall b a. (a, b) -> (a, b) +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.hs b/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.hs new file mode 100644 index 0000000000..579380f5f9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ParensAroundContext where + +f :: (_) => a -> a -> Bool +f x y = x == y diff --git a/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr b/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr new file mode 100644 index 0000000000..53fb335e8c --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + f :: forall a. Eq a => a -> a -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/PatBind.hs b/testsuite/tests/partial-sigs/should_compile/PatBind.hs new file mode 100644 index 0000000000..79930f9c82 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/PatBind.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module PatBind where + +foo :: _ +Just foo = Just id diff --git a/testsuite/tests/partial-sigs/should_compile/PatBind.stderr b/testsuite/tests/partial-sigs/should_compile/PatBind.stderr new file mode 100644 index 0000000000..492cde1197 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/PatBind.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: forall a. a -> a +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-0.5.1.0] diff --git a/testsuite/tests/partial-sigs/should_compile/PatBind2.hs b/testsuite/tests/partial-sigs/should_compile/PatBind2.hs new file mode 100644 index 0000000000..93780b5d49 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/PatBind2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module PatBind2 where + +foo :: Bool -> _ +Just foo = Just id diff --git a/testsuite/tests/partial-sigs/should_compile/PatBind2.stderr b/testsuite/tests/partial-sigs/should_compile/PatBind2.stderr new file mode 100644 index 0000000000..7454a4c418 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/PatBind2.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + f :: Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-0.5.1.0]
\ No newline at end of file diff --git a/testsuite/tests/partial-sigs/should_compile/PatternSig.hs b/testsuite/tests/partial-sigs/should_compile/PatternSig.hs new file mode 100644 index 0000000000..42727d717d --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/PatternSig.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, ScopedTypeVariables #-} +module PatternSig where + +bar :: Bool -> Bool +bar (x :: _) = True diff --git a/testsuite/tests/partial-sigs/should_compile/PatternSig.stderr b/testsuite/tests/partial-sigs/should_compile/PatternSig.stderr new file mode 100644 index 0000000000..3d8f949fd0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/PatternSig.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bar :: Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Recursive.hs b/testsuite/tests/partial-sigs/should_compile/Recursive.hs new file mode 100644 index 0000000000..8b2ebc3fb4 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Recursive.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module Recursive where + +orr :: a -> a -> a +orr = undefined + +g :: _ +g = f `orr` True + +f :: _ +f = g diff --git a/testsuite/tests/partial-sigs/should_compile/Recursive.stderr b/testsuite/tests/partial-sigs/should_compile/Recursive.stderr new file mode 100644 index 0000000000..71258f48ff --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Recursive.stderr @@ -0,0 +1,9 @@ +TYPE SIGNATURES + f :: Bool + g :: Bool + orr :: forall a. a -> a -> a +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.hs b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.hs new file mode 100644 index 0000000000..794c8dd5cf --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} + +module ScopedNamedWildcards where + +test3 :: _ +test3 x = const (let x :: _b + x = True in False) $ + const (let x :: _b + x = 'a' in True) $ + not x diff --git a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr new file mode 100644 index 0000000000..9757f043c8 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + test3 :: Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.hs b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.hs new file mode 100644 index 0000000000..725cf2902b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} + +module ScopedNamedWildcardsGood where + +-- The named wildcards aren't scoped as the ScopedTypeVariables extension +-- isn't enabled, of which the behaviour is copied. Thus, the _a annotation of +-- x, which must be Bool, isn't the same as the _a in g, which is now +-- generalised over. +foo :: _a -> _ +foo x = let v = not x + g :: _a -> _a + g x = x + in (g 'x') diff --git a/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr new file mode 100644 index 0000000000..7b9d39fe7d --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + foo :: Bool -> Char +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ShowNamed.hs b/testsuite/tests/partial-sigs/should_compile/ShowNamed.hs new file mode 100644 index 0000000000..e723214a00 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ShowNamed.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module ShowNamed where + +showTwo :: Show _a => _a -> String +showTwo x = show x diff --git a/testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr b/testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr new file mode 100644 index 0000000000..51e56f1b20 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + showTwo :: forall w_a. Show w_a => w_a -> String +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/SimpleGen.hs b/testsuite/tests/partial-sigs/should_compile/SimpleGen.hs new file mode 100644 index 0000000000..407328044e --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SimpleGen.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module SimpleGen where + +bar :: _ -> Bool +bar _ = True diff --git a/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr b/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr new file mode 100644 index 0000000000..96df17eb77 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + bar :: forall w_. w_ -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/SkipMany.hs b/testsuite/tests/partial-sigs/should_compile/SkipMany.hs new file mode 100644 index 0000000000..4be2b0fe27 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SkipMany.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module SkipMany where + +data GenParser tok st a = GenParser tok st a + +skipMany' :: GenParser tok st a -> GenParser tok st () +skipMany' = undefined + +skipMany :: _ -> _ () +skipMany = skipMany' diff --git a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr new file mode 100644 index 0000000000..0ebd18b172 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr @@ -0,0 +1,12 @@ +TYPE SIGNATURES + skipMany :: + forall tok st a. GenParser tok st a -> GenParser tok st () + skipMany' :: + forall tok st a. GenParser tok st a -> GenParser tok st () +TYPE CONSTRUCTORS + data GenParser tok st a = GenParser tok st a + Promotable +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs new file mode 100644 index 0000000000..6faadfecde --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module SomethingShowable where + +somethingShowable :: Show _x => _x -> _ +somethingShowable x = show (not x) +-- Inferred type: Bool -> String diff --git a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr new file mode 100644 index 0000000000..f33d433431 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + somethingShowable :: Bool -> String +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Uncurry.hs b/testsuite/tests/partial-sigs/should_compile/Uncurry.hs new file mode 100644 index 0000000000..130195ffbb --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Uncurry.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module Uncurry where + +unc :: (_ -> _ -> _) -> (_, _) -> _ +unc = uncurry diff --git a/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr b/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr new file mode 100644 index 0000000000..96b90d37ef --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + unc :: forall w_ w_1 w_2. (w_1 -> w_2 -> w_) -> (w_1, w_2) -> w_ +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/UncurryNamed.hs b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.hs new file mode 100644 index 0000000000..9bc7b460bd --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module UncurryNamed where + +unc :: (_a -> _b -> _c) -> (_a, _b) -> _c +unc = uncurry diff --git a/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr new file mode 100644 index 0000000000..1468252f58 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + unc :: forall w_a w_b w_c. (w_a -> w_b -> w_c) -> (w_a, w_b) -> w_c +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.hs b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.hs new file mode 100644 index 0000000000..765313a5e4 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards, ScopedTypeVariables, RankNTypes #-} +module WildcardInstantiations where + + +foo :: (Show _a, _) => _a -> _ +foo x = show (succ x) + +bar :: _ -> _ -> _ +bar x y = y x diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr new file mode 100644 index 0000000000..af573c5ffa --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr @@ -0,0 +1,48 @@ +TYPE SIGNATURES + bar :: forall w_ w_1. w_ -> (w_ -> w_1) -> w_1 + foo :: forall w_a. (Show w_a, Enum w_a) => w_a -> String +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, + integer-gmp-1.0.0.0] + + +WarningWildcardInstantiations.hs:5:14: Warning: + Found hole ‘_a’ with type: w_a + Where: ‘w_a’ is a rigid type variable bound by + the inferred type of foo :: (Enum w_a, Show w_a) => w_a -> String + at WarningWildcardInstantiations.hs:6:1 + In the type signature for ‘foo’: (Show _a, _) => _a -> _ + +WarningWildcardInstantiations.hs:5:18: Warning: + Found hole ‘_’ with inferred constraints: (Enum w_a) + In the type signature for ‘foo’: (Show _a, _) => _a -> _ + +WarningWildcardInstantiations.hs:5:30: Warning: + Found hole ‘_’ with type: String + In the type signature for ‘foo’: (Show _a, _) => _a -> _ + +WarningWildcardInstantiations.hs:8:8: Warning: + Found hole ‘_’ with type: w_ + Where: ‘w_’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WarningWildcardInstantiations.hs:9:1 + In the type signature for ‘bar’: _ -> _ -> _ + +WarningWildcardInstantiations.hs:8:13: Warning: + Found hole ‘_’ with type: w_ -> w_1 + Where: ‘w_’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WarningWildcardInstantiations.hs:9:1 + ‘w_1’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WarningWildcardInstantiations.hs:9:1 + In the type signature for ‘bar’: _ -> _ -> _ + + WarningWildcardInstantiations.hs:8:18: Warning: + Found hole ‘_’ with type: w_1 + Where: ‘w_1’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WarningWildcardInstantiations.hs:9:1 + In the type signature for ‘bar’: _ -> _ -> _ diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T new file mode 100644 index 0000000000..52a532f32f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -0,0 +1,48 @@ +test('ADT', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('AddAndOr1', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('AddAndOr2', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('AddAndOr3', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('AddAndOr4', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('AddAndOr5', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('AddAndOr6', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('BoolToBool', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Defaulting1MROn', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Defaulting2MROff', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Defaulting2MROn', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Either', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Every', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('EveryNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +# Bug +test('EqualityConstraint', expect_fail, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ExpressionSig', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ExpressionSigNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ExtraConstraints1', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ExtraConstraints2', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ExtraConstraints3', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +# Bug +test('ExtraNumAMROn', expect_fail, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ExtraNumAMROff', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Forall1', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('GenNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('HigherRank1', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('HigherRank2', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('LocalDefinitionBug', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Meltdown', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +# Bug +test('MonoLocalBinds', expect_fail, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('NamedTyVar', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ParensAroundContext', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('PatBind', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +# Bug +test('PatBind2', expect_fail, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('PatternSig', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Recursive', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ScopedNamedWildcards', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ScopedNamedWildcardsGood', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('ShowNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('SimpleGen', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('SkipMany', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('SomethingShowable', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('Uncurry', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('UncurryNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('WarningWildcardInstantiations', normal, compile, ['-ddump-types']) diff --git a/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.hs b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.hs new file mode 100644 index 0000000000..f79ed44a44 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module NamedWildcardsEnabled where + +foo :: Eq a => a -> (a, _) +foo x = (x, x) + +test = foo id + +-- As id (forall a. a -> a) doesn't implement Eq, the we cannot apply +-- foo with it. This test checks that foo gets the annotated type, +-- including constraints, not just the inferred type. diff --git a/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.stderr b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.stderr new file mode 100644 index 0000000000..5211cda013 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.stderr @@ -0,0 +1,7 @@ + +AnnotatedConstraint.hs:7:8: + No instance for (Eq (a0 -> a0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘foo’ + In the expression: foo id + In an equation for ‘test’: test = foo id diff --git a/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.hs b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.hs new file mode 100644 index 0000000000..73a5679a25 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AnnotatedConstraintNotForgotten where + +foo :: (Eq a, _) => a -> String +foo x = show x + + +data Foo = Foo deriving Show + + +-- Foo doesn't implement Eq, so `foo Foo` should fail. This is to +-- verify that the final type of foo didn't forget about the annotated +-- `Eq a` constraint. +test :: String +test = foo Foo diff --git a/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.stderr b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.stderr new file mode 100644 index 0000000000..5882a7861c --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.stderr @@ -0,0 +1,5 @@ + +AnnotatedConstraintNotForgotten.hs:15:8: + No instance for (Eq Foo) arising from a use of ‘foo’ + In the expression: foo Foo + In an equation for ‘test’: test = foo Foo diff --git a/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs new file mode 100644 index 0000000000..0e101ff2c6 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module Defaulting1MROff where + +alpha :: _ +alpha = 3 diff --git a/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr new file mode 100644 index 0000000000..8692475e54 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr @@ -0,0 +1,6 @@ + +Defaulting1MROff.hs:6:1: + No instance for (Num w_) + When checking that ‘alpha’ has the specified type + alpha :: forall w_. w_ + Probable cause: the inferred type is ambiguous diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.hs new file mode 100644 index 0000000000..320462519f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.hs @@ -0,0 +1,8 @@ +module ExtraConstraintsWildcardNotEnabled where + + +show' :: _ => a -> String +show' x = show x + +-- with the PartialTypeSignatures extension enabled this would lead to the +-- type Show a => a -> String diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr new file mode 100644 index 0000000000..c1007c2a8f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr @@ -0,0 +1,5 @@ + +ExtraConstraintsWildcardNotEnabled.hs:4:10: + Found hole ‘_’ with inferred constraints: (Show a) + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘show'’: _ => a -> String diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.hs new file mode 100644 index 0000000000..bbd4ed365a --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraintsWildcardNotLast where + +foo :: (_, Eq a) => a -> a +foo = undefined diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr new file mode 100644 index 0000000000..3b96a38fe2 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr @@ -0,0 +1,6 @@ + +ExtraConstraintsWildcardNotLast.hs:4:9: + Invalid partial type signature: + (_, Eq a) => a -> a + An extra-constraints wildcard is only allowed + at the end of the constraints diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.hs new file mode 100644 index 0000000000..6cb496464b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraintsWildcardNotPresent where + + +show' :: a -> _ +show' x = show x + +-- With an extra-constraints wildcard present, this would lead to the +-- type Show a => a -> String. + +-- This test makes sure that not merely having a partial type +-- signature is enough to generate extra constraints, an +-- extra-constraints wildcard is needed. diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr new file mode 100644 index 0000000000..f0549a5257 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr @@ -0,0 +1,6 @@ + +ExtraConstraintsWildcardNotPresent.hs:6:1: + No instance for (Show a) + When checking that ‘show'’ has the specified type + show' :: forall a. a -> String + Probable cause: the inferred type is ambiguous diff --git a/testsuite/tests/partial-sigs/should_fail/Forall1Bad.hs b/testsuite/tests/partial-sigs/should_fail/Forall1Bad.hs new file mode 100644 index 0000000000..cac8d911fd --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/Forall1Bad.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-} +module Forall1 where + +fall :: forall a. _ -> a +fall v = v + +-- The wildcard should unify with a +test :: Char +test = fall True diff --git a/testsuite/tests/partial-sigs/should_fail/Forall1Bad.stderr b/testsuite/tests/partial-sigs/should_fail/Forall1Bad.stderr new file mode 100644 index 0000000000..266232cab0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/Forall1Bad.stderr @@ -0,0 +1,5 @@ + +Forall1Bad.hs:9:13: + Couldn't match expected type ‘Char’ with actual type ‘Bool’ + In the first argument of ‘fall’, namely ‘True’ + In the expression: fall True diff --git a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.hs b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.hs new file mode 100644 index 0000000000..daaa06c80f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NamedWildcards #-} +module InstantiatedNamedWildcardsInConstraints where + +foo :: (Enum _a, _) => _a -> (String, b) +foo x = (show (succ x), x) diff --git a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr new file mode 100644 index 0000000000..4a80c48e30 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr @@ -0,0 +1,13 @@ + +InstantiatedNamedWildcardsInConstraints.hs:4:14: + Found hole ‘_a’ with type: b + Where: ‘b’ is a rigid type variable bound by + the inferred type of foo :: (Enum b, Show b) => b -> (String, b) + at InstantiatedNamedWildcardsInConstraints.hs:4:8 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: (Enum _a, _) => _a -> (String, b) + +InstantiatedNamedWildcardsInConstraints.hs:4:18: + Found hole ‘_’ with inferred constraints: (Show b) + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: (Enum _a, _) => _a -> (String, b) diff --git a/testsuite/tests/partial-sigs/should_fail/Makefile b/testsuite/tests/partial-sigs/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.hs b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.hs new file mode 100644 index 0000000000..8b7372c7f5 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module NamedExtraConstraintsWildcard where + +foo :: (Eq a, _a) => a -> a +foo = undefined diff --git a/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr new file mode 100644 index 0000000000..783b2c0f33 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr @@ -0,0 +1,5 @@ + +NamedExtraConstraintsWildcard.hs:4:15: + Invalid partial type signature: + (Eq a, _a) => a -> a + A named wildcard cannot occur as a constraint diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.hs b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.hs new file mode 100644 index 0000000000..fe5e606966 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NamedWildcards #-} +module NamedWildcardsEnabled where + +foo :: _a -> _b +foo x = not x diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr new file mode 100644 index 0000000000..90293ac714 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr @@ -0,0 +1,10 @@ + +NamedWildcardsEnabled.hs:4:8: + Found hole ‘_a’ with type: Bool + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: _a -> _b + +NamedWildcardsEnabled.hs:4:14: + Found hole ‘_b’ with type: Bool + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: _a -> _b diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.hs b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.hs new file mode 100644 index 0000000000..a6ae0788c8 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.hs @@ -0,0 +1,7 @@ +module NamedWildcardsNotEnabled where + +foo :: _a -> _b +foo x = not x + +-- with the NamedWildcards extension enabled this would lead to the +-- type Bool -> Bool. diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr new file mode 100644 index 0000000000..7c61bf6c02 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr @@ -0,0 +1,21 @@ + +NamedWildcardsNotEnabled.hs:4:9: + Couldn't match expected type ‘_b’ with actual type ‘Bool’ + ‘_b’ is a rigid type variable bound by + the type signature for foo :: _a -> _b + at NamedWildcardsNotEnabled.hs:3:8 + Relevant bindings include + foo :: _a -> _b (bound at NamedWildcardsNotEnabled.hs:4:1) + In the expression: not x + In an equation for ‘foo’: foo x = not x + +NamedWildcardsNotEnabled.hs:4:13: + Couldn't match expected type ‘Bool’ with actual type ‘_a’ + ‘_a’ is a rigid type variable bound by + the type signature for foo :: _a -> _b + at NamedWildcardsNotEnabled.hs:3:8 + Relevant bindings include + x :: _a (bound at NamedWildcardsNotEnabled.hs:4:5) + foo :: _a -> _b (bound at NamedWildcardsNotEnabled.hs:4:1) + In the first argument of ‘not’, namely ‘x’ + In the expression: not x diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs new file mode 100644 index 0000000000..6b5650c2f9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards #-} +module NamedWildcardsNotInMonotype where + +foo :: (Show _a, Eq _c, Eq _b) => _a -> _b -> String +foo x y = show x ++ show (x == y) diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr new file mode 100644 index 0000000000..82b8f832b1 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr @@ -0,0 +1,6 @@ + +NamedWildcardsNotInMonotype.hs:4:21: + Invalid partial type signature: + (Show _a, Eq _c, Eq _b) => _a -> _b -> String + The named wildcard ‘_c’ is only allowed in the constraints + when it also occurs in the (mono)type diff --git a/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.hs b/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.hs new file mode 100644 index 0000000000..1d32844fd0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RankNTypes, PartialTypeSignatures #-} +module NestedExtraConstraintsWildcard where + +foo :: Bool -> (Eq a, _) => a +foo = undefined diff --git a/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr new file mode 100644 index 0000000000..58200476ad --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr @@ -0,0 +1,6 @@ + +NestedExtraConstraintsWildcard.hs:4:23: + Invalid partial type signature: + Bool -> (Eq a, _) => a + An extra-constraints wildcard is only allowed + at the top-level of the signature diff --git a/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.hs b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.hs new file mode 100644 index 0000000000..d906eaf82d --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RankNTypes, PartialTypeSignatures, NamedWildcards #-} +module NestedNamedExtraConstraintsWildcard where + +foo :: Bool -> (Eq a, _a) => a +foo = undefined diff --git a/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr new file mode 100644 index 0000000000..a5cb766bbe --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr @@ -0,0 +1,5 @@ + +NestedNamedExtraConstraintsWildcard.hs:4:23: + Invalid partial type signature: + Bool -> (Eq a, _a) => a + A named wildcard cannot occur as a constraint diff --git a/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.hs b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.hs new file mode 100644 index 0000000000..377347b0a2 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module PartialClassMethodSignature where + + +class Foo a where + foo :: (Eq a, _) => a -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr new file mode 100644 index 0000000000..c6a878878e --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr @@ -0,0 +1,5 @@ + +PartialClassMethodSignature.hs:6:17: + The type signature of a class method cannot be partial: + foo :: (Eq a, _) => a -> _ + In the class declaration for ‘Foo’ diff --git a/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.hs b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.hs new file mode 100644 index 0000000000..c63dc978f0 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.hs @@ -0,0 +1,5 @@ +module PartialTypeSignaturesEnabled where + +-- The PartialTypeSignatures extension should be enabled +foo :: _ -> _ +foo x = not x diff --git a/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr new file mode 100644 index 0000000000..727d922c23 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr @@ -0,0 +1,10 @@ + +PartialTypeSignaturesDisabled.hs:4:8: + Found hole ‘_’ with type: Bool + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: _ -> _ + +PartialTypeSignaturesDisabled.hs:4:13: + Found hole ‘_’ with type: Bool + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: _ -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.hs b/testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.hs new file mode 100644 index 0000000000..df0d3b8111 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards, ScopedTypeVariables #-} + +module ScopedNamedWildcardsBad where + +-- If named wildcards are properly scoped, this should lead to +-- a constraint (Bool ~ Char) +foo :: _a -> _ +foo x = let v = not x + g :: _a -> _a + g x = x + in (g 'x') diff --git a/testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.stderr b/testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.stderr new file mode 100644 index 0000000000..b943dfba2b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.stderr @@ -0,0 +1,5 @@ + +ScopedNamedWildcardsBad.hs:8:21: + Couldn't match expected type ‘Bool’ with actual type ‘Char’ + In the first argument of ‘not’, namely ‘x’ + In the expression: not x diff --git a/testsuite/tests/partial-sigs/should_fail/TidyClash.hs b/testsuite/tests/partial-sigs/should_fail/TidyClash.hs new file mode 100644 index 0000000000..73464ab027 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/TidyClash.hs @@ -0,0 +1,9 @@ +module TidyClash where + +-- Type variables originating from wildcards are normally given the name w_, +-- but in this case there is already a type variable called w_. Tidying the +-- types should result in w_1 and w_2 for the two new type variables +-- originating from the wildcards. + +bar :: w_ -> (w_, _ -> _) +bar x = (x, \y -> undefined) diff --git a/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr b/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr new file mode 100644 index 0000000000..6d8070a339 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr @@ -0,0 +1,16 @@ + +TidyClash.hs:8:19: + Found hole ‘_’ with type: w_ + Where: ‘w_’ is a rigid type variable bound by + the inferred type of bar :: w_2 -> (w_2, w_ -> w_1) + at TidyClash.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘bar’: w_ -> (w_, _ -> _) + +TidyClash.hs:8:24: + Found hole ‘_’ with type: w_1 + Where: ‘w_1’ is a rigid type variable bound by + the inferred type of bar :: w_2 -> (w_2, w_ -> w_1) + at TidyClash.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘bar’: w_ -> (w_, _ -> _) diff --git a/testsuite/tests/partial-sigs/should_fail/TidyClash2.hs b/testsuite/tests/partial-sigs/should_fail/TidyClash2.hs new file mode 100644 index 0000000000..7a2cab3430 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/TidyClash2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NamedWildcards, ScopedTypeVariables #-} +module TidyClash2 where + +barry :: forall w_. _ -> _ -> w_ +barry (x :: _) (y :: _) = undefined :: _ diff --git a/testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr b/testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr new file mode 100644 index 0000000000..1e8a1985d3 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr @@ -0,0 +1,54 @@ + +TidyClash2.hs:4:21: + Found hole ‘_’ with type: w_1 + Where: ‘w_1’ is a rigid type variable bound by + the inferred type of barry :: w_1 -> w_2 -> w_ at TidyClash2.hs:5:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘barry’: _ -> _ -> w_ + +TidyClash2.hs:4:26: + Found hole ‘_’ with type: w_2 + Where: ‘w_2’ is a rigid type variable bound by + the inferred type of barry :: w_1 -> w_2 -> w_ at TidyClash2.hs:5:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘barry’: _ -> _ -> w_ + +TidyClash2.hs:5:13: + Found hole ‘_’ with type: w_1 + Where: ‘w_1’ is a rigid type variable bound by + the inferred type of barry :: w_1 -> w_2 -> w_ at TidyClash2.hs:5:1 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + barry :: w_1 -> w_2 -> w_ (bound at TidyClash2.hs:5:1) + In a pattern type signature: _ + In the pattern: x :: _ + In an equation for ‘barry’: + barry (x :: _) (y :: _) = undefined :: _ + +TidyClash2.hs:5:22: + Found hole ‘_’ with type: w_2 + Where: ‘w_2’ is a rigid type variable bound by + the inferred type of barry :: w_1 -> w_2 -> w_ at TidyClash2.hs:5:1 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + x :: w_1 (bound at TidyClash2.hs:5:8) + barry :: w_1 -> w_2 -> w_ (bound at TidyClash2.hs:5:1) + In a pattern type signature: _ + In the pattern: y :: _ + In an equation for ‘barry’: + barry (x :: _) (y :: _) = undefined :: _ + +TidyClash2.hs:5:40: + Found hole ‘_’ with type: w_ + Where: ‘w_’ is a rigid type variable bound by + the inferred type of barry :: w_1 -> w_2 -> w_ + at TidyClash2.hs:4:17 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + y :: w_2 (bound at TidyClash2.hs:5:17) + x :: w_1 (bound at TidyClash2.hs:5:8) + barry :: w_1 -> w_2 -> w_ (bound at TidyClash2.hs:5:1) + In an expression type signature: _ + In the expression: undefined :: _ + In an equation for ‘barry’: + barry (x :: _) (y :: _) = undefined :: _ diff --git a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.hs b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.hs new file mode 100644 index 0000000000..f03cd679b1 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module UnnamedConstraintWildcard1 where + +foo :: Show _ => a -> String +foo x = show x diff --git a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr new file mode 100644 index 0000000000..5ade51628b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr @@ -0,0 +1,5 @@ + +UnnamedConstraintWildcard1.hs:4:13: + Invalid partial type signature: + Show _ => a -> String + Wildcards are not allowed within the constraints diff --git a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.hs b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.hs new file mode 100644 index 0000000000..015297d380 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module UnnamedConstraintWildcard2 where + +foo :: _ a => a -> String +foo x = show x diff --git a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr new file mode 100644 index 0000000000..e0872ba70a --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr @@ -0,0 +1,5 @@ + +UnnamedConstraintWildcard2.hs:4:8: + Invalid partial type signature: + _ a => a -> String + Wildcards are not allowed within the constraints diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.hs new file mode 100644 index 0000000000..3cedc38ce2 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInADT1 where + +data Foo a = Foo (Either _ a) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr new file mode 100644 index 0000000000..617d2b8d9e --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr @@ -0,0 +1,4 @@ + +WildcardInADT1.hs:4:26: + A constructor cannot have a partial type: + Foo (Either _ a) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.hs new file mode 100644 index 0000000000..3872a2557e --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInADT2 where + +data Foo a = Foo { get :: Either _ a } diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr new file mode 100644 index 0000000000..b8c57b6f92 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr @@ -0,0 +1,4 @@ + +WildcardInADT2.hs:4:34: + A constructor cannot have a partial type: + Foo {get :: Either _ a} diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.hs new file mode 100644 index 0000000000..95a266b903 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} +module WildcardInADT3 where + +data Foo a = Foo { get :: _ => a } diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr new file mode 100644 index 0000000000..85e052512b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr @@ -0,0 +1,4 @@ + +WildcardInADT3.hs:4:27: + A constructor cannot have a partial type: + Foo {get :: _ => a} diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.hs new file mode 100644 index 0000000000..850cca8213 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures, DatatypeContexts #-} +module WildcardInADTContext where + +data (Eq a, _) => Foo a = Foo { getFoo :: a } diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr new file mode 100644 index 0000000000..29a3dbbf53 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr @@ -0,0 +1,7 @@ + +WildcardInADTContext1.hs:1:37: Warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +WildcardInADTContext1.hs:4:13: + Wildcard not allowed + In the context: (Eq a, _) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.hs new file mode 100644 index 0000000000..5923bc23b7 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures, NamedWildcards, DatatypeContexts #-} +module WildcardInADTContext2 where + +data (Eq _a) => Foo a = Foo { getFoo :: a } diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr new file mode 100644 index 0000000000..96ba8358ea --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr @@ -0,0 +1,7 @@ + +WildcardInADTContext2.hs:1:53: Warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +WildcardInADTContext2.hs:4:10: + Wildcard not allowed + In the context: (Eq _a) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.hs new file mode 100644 index 0000000000..31e72ad290 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInDefault where + +default (_) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr new file mode 100644 index 0000000000..a0a7e38563 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr @@ -0,0 +1,4 @@ + +WildcardInDefault.hs:4:10: + Wildcard not allowed + In declaration: default (_) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.hs new file mode 100644 index 0000000000..f08437b7f1 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInDeriving where + +data Foo a = Foo a + deriving (_) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr new file mode 100644 index 0000000000..18397f5606 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr @@ -0,0 +1,4 @@ + +WildcardInDeriving.hs:5:22: + Wildcard not allowed + In the deriving items: (_) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.hs new file mode 100644 index 0000000000..0fe539ca7f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures, ForeignFunctionInterface #-} +module WildcardInForeignExport where + +import Foreign.C + +foreign export ccall foo :: CInt -> _ +foo = undefined diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr new file mode 100644 index 0000000000..a56145e2c7 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr @@ -0,0 +1,5 @@ + +WildcardInForeignExport.hs:6:37: + Wildcard not allowed + In foreign export declaration ‘foo’ + CInt -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.hs new file mode 100644 index 0000000000..a0fd54122c --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures, ForeignFunctionInterface #-} +module WildcardInForeignImport where + +import Foreign.C + +foreign import ccall "sin" c_sin :: CDouble -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr new file mode 100644 index 0000000000..b6a781a313 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr @@ -0,0 +1,5 @@ + +WildcardInForeignImport.hs:6:48: + Wildcard not allowed + In foreign import declaration ‘c_sin’ + CDouble -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.hs new file mode 100644 index 0000000000..42ae89e7c9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, GADTs #-} +module WildcardInGADT1 where + +data Foo a where + Foo :: Either a _ -> Foo a diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr new file mode 100644 index 0000000000..bd20ffb36d --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr @@ -0,0 +1,4 @@ + +WildcardInGADT1.hs:5:19: + A constructor cannot have a partial type: + Foo :: Either a _ -> Foo a diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.hs new file mode 100644 index 0000000000..187f60e214 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures, GADTs #-} +module WildcardInGADT2 where + +data Foo a where + Foo :: (Eq a, _) => Maybe a -> Foo a diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr new file mode 100644 index 0000000000..a2e9d10fa9 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr @@ -0,0 +1,4 @@ + +WildcardInGADT2.hs:5:17: + A constructor cannot have a partial type: + (Eq a, _) => Maybe a -> Foo a diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.hs new file mode 100644 index 0000000000..86e5fae347 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInInstanceHead where + +class Foo k where + bar :: k + +instance Foo _ where + bar = 3 diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr new file mode 100644 index 0000000000..3b5e078c17 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr @@ -0,0 +1,4 @@ + +WildcardInInstanceHead.hs:7:14: + Wildcard not allowed + In instance head: Foo _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.hs new file mode 100644 index 0000000000..65d8b0b03c --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInNewtype where + +-- Currently handled by the same checks as for ADTs, but in case this +-- changes in the future, add at least one test. + +newtype Foo a = Foo (Either _ a) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr new file mode 100644 index 0000000000..f7767332b5 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr @@ -0,0 +1,4 @@ + +WildcardInNewtype.hs:7:29: + A constructor cannot have a partial type: + Foo (Either _ a) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.hs new file mode 100644 index 0000000000..ae49863748 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} +module WildcardInPatSynSig where + +pattern Single :: () => (Show a) => _ -> [a] +pattern Single x = [x] diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr new file mode 100644 index 0000000000..06ee17e212 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr @@ -0,0 +1,5 @@ + +WildcardInPatSynSig.hs:4:37: + Wildcard not allowed + In pattern synonym type signature: + pattern Single :: () => (Show a) => _ -> [a] diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.hs new file mode 100644 index 0000000000..3fca6bc7a2 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PartialTypeSignatures, TypeFamilies, InstanceSigs #-} +module WildcardInTypeFamilyInstanceLHS where + +class Foo k where + type Dual k :: * + +instance Foo Int where + type Dual _ = Maybe Int diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.stderr new file mode 100644 index 0000000000..2aac87c766 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.stderr @@ -0,0 +1,4 @@ + +WildcardInTypeFamilyInstanceLHS.hs:8:13: + Wildcard not allowed + In type family instance equation of ‘Dual’: Dual _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.hs new file mode 100644 index 0000000000..96a472a118 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PartialTypeSignatures, TypeFamilies, InstanceSigs #-} +module WildcardInTypeFamilyInstanceRHS where + +class Foo k where + type Dual k :: * + +instance Foo Int where + type Dual Int = Maybe _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr new file mode 100644 index 0000000000..e74b47371f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr @@ -0,0 +1,4 @@ + +WildcardInTypeFamilyInstanceRHS.hs:8:25: + Wildcard not allowed + In type family instance equation of ‘Dual’: Maybe _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.hs new file mode 100644 index 0000000000..9b4db756ab --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInTypeSynonymLHS where + +type Foo _ = Int diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.stderr new file mode 100644 index 0000000000..ec438805e4 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.stderr @@ -0,0 +1,6 @@ + +WildcardInTypeSynonymLHS.hs:4:10: + Unexpected type ‘_’ + In the type declaration for ‘Foo’ + A type declaration should have form + type Foo a = ... diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.hs new file mode 100644 index 0000000000..186370575a --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WildcardInTypeSynonymRHS where + +type Foo = Maybe _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr new file mode 100644 index 0000000000..ea9b246f96 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr @@ -0,0 +1,4 @@ + +WildcardInTypeSynonymRHS.hs:4:18: + Wildcard not allowed + In type synonym ‘Foo’: Maybe _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.hs new file mode 100644 index 0000000000..ff4c61cb62 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NamedWildcards, ScopedTypeVariables, RankNTypes #-} +module WildcardInstantiations where + + +foo :: (Show _a, _) => _a -> _ +foo x = show (succ x) + +bar :: _ -> _ -> _ +bar x y = y x diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr new file mode 100644 index 0000000000..5701bfd623 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr @@ -0,0 +1,45 @@ + +WildcardInstantiations.hs:5:14: + Found hole ‘_a’ with type: w_a + Where: ‘w_a’ is a rigid type variable bound by + the inferred type of foo :: (Enum w_a, Show w_a) => w_a -> String + at WildcardInstantiations.hs:6:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: (Show _a, _) => _a -> _ + +WildcardInstantiations.hs:5:18: + Found hole ‘_’ with inferred constraints: (Enum w_a) + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: (Show _a, _) => _a -> _ + +WildcardInstantiations.hs:5:30: + Found hole ‘_’ with type: String + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘foo’: (Show _a, _) => _a -> _ + +WildcardInstantiations.hs:8:8: + Found hole ‘_’ with type: w_ + Where: ‘w_’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WildcardInstantiations.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘bar’: _ -> _ -> _ + +WildcardInstantiations.hs:8:13: + Found hole ‘_’ with type: w_ -> w_1 + Where: ‘w_’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WildcardInstantiations.hs:9:1 + ‘w_1’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WildcardInstantiations.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘bar’: _ -> _ -> _ + +WildcardInstantiations.hs:8:18: + Found hole ‘_’ with type: w_1 + Where: ‘w_1’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_ -> w_1) -> w_1 + at WildcardInstantiations.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘bar’: _ -> _ -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.hs b/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.hs new file mode 100644 index 0000000000..a8a069df50 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NamedWildcards, ScopedTypeVariables #-} +module WildcardsInPatternAndExprSig where + +bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) = [x, z] :: [_d] diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr new file mode 100644 index 0000000000..c53d223307 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr @@ -0,0 +1,74 @@ + +WildcardsInPatternAndExprSig.hs:4:18: + Found hole ‘_a’ with type: w_c + Where: ‘w_c’ is a rigid type variable bound by + the inferred type of bar :: Maybe [w_c] -> w_c -> [w_c] + at WildcardsInPatternAndExprSig.hs:4:1 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + bar :: Maybe [w_c] -> w_c -> [w_c] + (bound at WildcardsInPatternAndExprSig.hs:4:1) + In a pattern type signature: _a + In the pattern: x :: _a + In the pattern: [x :: _a] + +WildcardsInPatternAndExprSig.hs:4:25: + Found hole ‘_’ with type: [w_c] + Where: ‘w_c’ is a rigid type variable bound by + the inferred type of bar :: Maybe [w_c] -> w_c -> [w_c] + at WildcardsInPatternAndExprSig.hs:4:1 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + bar :: Maybe [w_c] -> w_c -> [w_c] + (bound at WildcardsInPatternAndExprSig.hs:4:1) + In a pattern type signature: _ + In the pattern: [x :: _a] :: _ + In the pattern: Just ([x :: _a] :: _) + +WildcardsInPatternAndExprSig.hs:4:38: + Found hole ‘_b’ with type: w_c + Where: ‘w_c’ is a rigid type variable bound by + the inferred type of bar :: Maybe [w_c] -> w_c -> [w_c] + at WildcardsInPatternAndExprSig.hs:4:1 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + bar :: Maybe [w_c] -> w_c -> [w_c] + (bound at WildcardsInPatternAndExprSig.hs:4:1) + In a pattern type signature: Maybe [_b] + In the pattern: Just ([x :: _a] :: _) :: Maybe [_b] + In an equation for ‘bar’: + bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) + = [x, z] :: [_d] + +WildcardsInPatternAndExprSig.hs:4:49: + Found hole ‘_c’ with type: w_c + Where: ‘w_c’ is a rigid type variable bound by + the inferred type of bar :: Maybe [w_c] -> w_c -> [w_c] + at WildcardsInPatternAndExprSig.hs:4:1 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + x :: w_c (bound at WildcardsInPatternAndExprSig.hs:4:13) + bar :: Maybe [w_c] -> w_c -> [w_c] + (bound at WildcardsInPatternAndExprSig.hs:4:1) + In a pattern type signature: _c + In the pattern: z :: _c + In an equation for ‘bar’: + bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) + = [x, z] :: [_d] + +WildcardsInPatternAndExprSig.hs:4:66: + Found hole ‘_d’ with type: w_c + Where: ‘w_c’ is a rigid type variable bound by + the inferred type of bar :: Maybe [w_c] -> w_c -> [w_c] + at WildcardsInPatternAndExprSig.hs:4:1 + To use the inferred type, enable PartialTypeSignatures + Relevant bindings include + z :: w_c (bound at WildcardsInPatternAndExprSig.hs:4:44) + x :: w_c (bound at WildcardsInPatternAndExprSig.hs:4:13) + bar :: Maybe [w_c] -> w_c -> [w_c] + (bound at WildcardsInPatternAndExprSig.hs:4:1) + In an expression type signature: [_d] + In the expression: [x, z] :: [_d] + In an equation for ‘bar’: + bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) + = [x, z] :: [_d] diff --git a/testsuite/tests/partial-sigs/should_fail/all.T b/testsuite/tests/partial-sigs/should_fail/all.T new file mode 100644 index 0000000000..ef08d3721b --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/all.T @@ -0,0 +1,42 @@ +test('AnnotatedConstraint', normal, compile_fail, ['']) +test('AnnotatedConstraintNotForgotten', normal, compile_fail, ['']) +test('Defaulting1MROff', normal, compile_fail, ['']) +test('ExtraConstraintsWildcardNotEnabled', normal, compile_fail, ['']) +test('ExtraConstraintsWildcardNotLast', normal, compile_fail, ['']) +test('ExtraConstraintsWildcardNotPresent', normal, compile_fail, ['']) +test('Forall1Bad', normal, compile_fail, ['']) +test('InstantiatedNamedWildcardsInConstraints', normal, compile_fail, ['']) +test('NamedExtraConstraintsWildcard', normal, compile_fail, ['']) +test('NamedWildcardsEnabled', normal, compile_fail, ['']) +test('NamedWildcardsNotEnabled', normal, compile_fail, ['']) +test('NamedWildcardsNotInMonotype', normal, compile_fail, ['']) +test('NestedExtraConstraintsWildcard', normal, compile_fail, ['']) +test('NestedNamedExtraConstraintsWildcard', normal, compile_fail, ['']) +test('PartialClassMethodSignature', normal, compile_fail, ['']) +test('PartialTypeSignaturesDisabled', normal, compile_fail, ['']) +test('ScopedNamedWildcardsBad', normal, compile_fail, ['']) +test('TidyClash', normal, compile_fail, ['']) +# Bug +test('TidyClash2', expect_fail, compile_fail, ['']) +test('UnnamedConstraintWildcard1', normal, compile_fail, ['']) +test('UnnamedConstraintWildcard2', normal, compile_fail, ['']) +test('WildcardInADT1', normal, compile_fail, ['']) +test('WildcardInADT2', normal, compile_fail, ['']) +test('WildcardInADT3', normal, compile_fail, ['']) +test('WildcardInADTContext1', normal, compile_fail, ['']) +test('WildcardInADTContext2', normal, compile_fail, ['']) +test('WildcardInDefault', normal, compile_fail, ['']) +test('WildcardInDeriving', normal, compile_fail, ['']) +test('WildcardInForeignExport', normal, compile_fail, ['']) +test('WildcardInForeignImport', normal, compile_fail, ['']) +test('WildcardInGADT1', normal, compile_fail, ['']) +test('WildcardInGADT2', normal, compile_fail, ['']) +test('WildcardInInstanceHead', normal, compile_fail, ['']) +test('WildcardsInPatternAndExprSig', normal, compile_fail, ['']) +test('WildcardInPatSynSig', normal, compile_fail, ['']) +test('WildcardInNewtype', normal, compile_fail, ['']) +test('WildcardInstantiations', normal, compile_fail, ['']) +test('WildcardInTypeFamilyInstanceLHS', normal, compile_fail, ['']) +test('WildcardInTypeFamilyInstanceRHS', normal, compile_fail, ['']) +test('WildcardInTypeSynonymLHS', normal, compile_fail, ['']) +test('WildcardInTypeSynonymRHS', normal, compile_fail, ['']) diff --git a/utils/haddock b/utils/haddock -Subproject 5d8117d8f1f910c85d36865d646b65510b23583 +Subproject 1a9dcfef033dd66514015d4a942ba67d21f9548 |