Implement Partial Type Signatures
authorThomas Winant <thomas.winant@cs.kuleuven.be>
Fri, 28 Nov 2014 22:08:10 +0000 (16:08 -0600)
committerAustin Seipp <austin@well-typed.com>
Fri, 28 Nov 2014 23:17:17 +0000 (17:17 -0600)
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:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/main/DynFlags.hs
compiler/main/ErrUtils.lhs
compiler/main/HscStats.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcPatSyn.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRules.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcValidity.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
docs/users_guide/flags.xml
docs/users_guide/glasgow_exts.xml
docs/users_guide/using.xml
testsuite/tests/driver/T4437.hs
testsuite/tests/partial-sigs/Makefile [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ADT.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ADT.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr3.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr4.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr5.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr6.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/BoolToBool.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Either.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Either.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/EqualityConstraint.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Every.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Every.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/EveryNamed.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExpressionSig.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Forall1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Forall1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/GenNamed.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/GenNamed.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/HigherRank1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/HigherRank2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Makefile [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Meltdown.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Meltdown.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/NamedTyVar.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ParensAroundContext.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/PatBind.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/PatBind.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/PatBind2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/PatBind2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/PatternSig.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/PatternSig.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Recursive.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Recursive.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ShowNamed.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/SimpleGen.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/SkipMany.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/SkipMany.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Uncurry.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/Uncurry.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/UncurryNamed.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/all.T [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/AnnotatedConstraint.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/AnnotatedConstraintNotForgotten.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/Forall1Bad.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/Forall1Bad.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/Makefile [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/ScopedNamedWildcardsBad.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/TidyClash.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/TidyClash.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/TidyClash2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADT1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADT2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADT3.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInDefault.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymLHS.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/all.T [new file with mode: 0644]
utils/haddock

index 515d352..2addbdf 100644 (file)
@@ -184,7 +184,7 @@ repTopDs group@(HsGroup { hs_valds   = valds
 hsSigTvBinders :: HsValBinds Name -> [Name]
 -- See Note [Scoped type variables in bindings]
 hsSigTvBinders binds
 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
                      , 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)]
                      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)
 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]
   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)
       = 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)
 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
   addTyVarBinds tvs $ \bndrs -> do
     ctxt1  <- repLContext ctxt
     ty1    <- repLTy ty
@@ -1073,7 +1073,7 @@ repE (RecordUpd e flds _ _ _)
         fs <- repFields flds;
         repRecUpd x fs }
 
         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 }
 repE (ArithSeq _ _ aseq) =
   case aseq of
     From e              -> do { ds1 <- repLE e; repFrom ds1 }
index 1a6f2cf..56282db 100644 (file)
@@ -168,7 +168,7 @@ cvtDec (TH.FunD nm cls)
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType typ
 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
 
 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
 
     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)}
     cvt (RecConE c flds) = do { c' <- cNameL c
                               ; flds' <- mapM cvtFld flds
                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
index e0a2193..74e34df 100644 (file)
@@ -424,7 +424,7 @@ plusHsValBinds _ _
 getTypeSigNames :: HsValBinds a -> NameSet
 -- Get the names that have a user type sig
 getTypeSigNames (ValBindsOut _ sigs)
 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}
 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@
 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'
       --
       --  - '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
 
       -- | 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 = 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
 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
index 0833c3c..82098e2 100644 (file)
@@ -275,6 +275,10 @@ data HsExpr id
   | ExprWithTySig
                 (LHsExpr id)
                 (LHsType 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)
 
   | 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 (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)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
          4 (ppr sig)
 ppr_expr (ExprWithTySigOut expr sig)
index e3d6071..bfeec5a 100644 (file)
@@ -41,9 +41,10 @@ module HsTypes (
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
+        isWildcardTy, isNamedWildcardTy,
 
         -- Printing
 
         -- Printing
-        pprParendHsType, pprHsForAll,
+        pprParendHsType, pprHsForAll, pprHsForAllExtra,
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
     ) where
 
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
     ) where
 
@@ -62,6 +63,7 @@ import SrcLoc
 import StaticFlags
 import Outputable
 import FastString
 import StaticFlags
 import Outputable
 import FastString
+import Maybes( isJust )
 
 import Data.Data hiding ( Fixity )
 import Data.Maybe ( fromMaybe )
 
 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 { 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]))
     }
   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
 
 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
 
 
 -- | 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
   = 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',
                 (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
   | 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)
 
   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 :: 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 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    
         -- 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 :: 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
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
@@ -485,6 +509,15 @@ hsLTyVarLocName = fmap hsTyVarName
 
 hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
 hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
 
 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}
 
 
 \end{code}
 
 
@@ -531,9 +564,9 @@ splitLHsForAllTy
     -> (LHsTyVarBndrs name, HsContext name, LHsType name)
 splitLHsForAllTy poly_ty
   = case unLoc poly_ty of
     -> (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])
         -- 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
 
 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
   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}
     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)
 
 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
 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_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 $
   = 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
 
 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 _    (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
 
 ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
   = ppr_mono_ty ctxt_prec ty
index 4709218..ed78964 100644 (file)
@@ -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 ] ++
                                        , 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
 
 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
   = L loc name : hsDataDefnBinders defn
 
index 11e5c32..1f022e9 100644 (file)
@@ -503,6 +503,7 @@ data WarningFlag =
    | Opt_WarnUnsupportedLlvmVersion
    | Opt_WarnInlineRuleShadowing
    | Opt_WarnTypedHoles
    | Opt_WarnUnsupportedLlvmVersion
    | Opt_WarnInlineRuleShadowing
    | Opt_WarnTypedHoles
+   | Opt_WarnPartialTypeSignatures
    | Opt_WarnMissingExportedSigs
    deriving (Eq, Show, Enum)
 
    | Opt_WarnMissingExportedSigs
    deriving (Eq, Show, Enum)
 
@@ -621,6 +622,8 @@ data ExtensionFlag
    | Opt_NegativeLiterals
    | Opt_EmptyCase
    | Opt_PatternSynonyms
    | Opt_NegativeLiterals
    | Opt_EmptyCase
    | Opt_PatternSynonyms
+   | Opt_PartialTypeSignatures
+   | Opt_NamedWildcards
    deriving (Eq, Enum, Show)
 
 data SigOf = NotSigOf
    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-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 ),
   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 ( "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,
   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 ( "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" ),
   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_WarnWarningsDeprecations,
         Opt_WarnDeprecatedFlags,
         Opt_WarnTypedHoles,
+        Opt_WarnPartialTypeSignatures,
         Opt_WarnUnrecognisedPragmas,
         Opt_WarnPointlessPragmas,
         Opt_WarnDuplicateConstraints,
         Opt_WarnUnrecognisedPragmas,
         Opt_WarnPointlessPragmas,
         Opt_WarnDuplicateConstraints,
index 12f484b..61f4335 100644 (file)
@@ -14,7 +14,7 @@ module ErrUtils (
         Messages, ErrorMessages, WarningMessages,
         errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
         mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
         Messages, ErrorMessages, WarningMessages,
         errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
         mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
-        pprLocErrMsg, makeIntoWarning,
+        pprLocErrMsg, makeIntoWarning, isWarning,
 
         errorsFound, emptyMessages, isEmptyMessages,
         mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
 
         errorsFound, emptyMessages, isEmptyMessages,
         mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
@@ -137,6 +137,10 @@ mkLocMessage severity locn msg
 makeIntoWarning :: ErrMsg -> ErrMsg
 makeIntoWarning err = err { errMsgSeverity = SevWarning }
 
 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.
 
 -- -----------------------------------------------------------------------------
 -- Collecting up messages for later ordering and printing.
 
index 582cb31..d32f619 100644 (file)
@@ -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)
     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)
     sig_info (SpecSig _ _ _)  = (0,0,1,0,0)
     sig_info (InlineSig _ _)  = (0,0,0,1,0)
     sig_info (GenericSig _ _) = (0,0,0,0,1)
index eb800ba..7f4e718 100644 (file)
@@ -57,7 +57,7 @@ import Outputable
 
 -- compiler/basicTypes
 import RdrName
 
 -- 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
 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))) }
         | 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
         | '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 }
                                      , 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)) } }
 
              ; 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
                                           ,$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
 
 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
 
           -- 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
                           ; 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] } }
 
                           ; 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
 
 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
         | 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 }
                                                  [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
 
 -- 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
 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
 
                 -- 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
         :
         -- 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 $> ()) [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
 
         | 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 }
                             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)
                                        [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>"
       ]
 
       , text "extension to enable explicit-forall syntax: \x2200 <tvs>. <type>"
       ]
 
+namedWildcardsEnabled :: P Bool
+namedWildcardsEnabled = liftM ((Opt_NamedWildcards `xopt`) . dflags) getPState
+
 {-
 %************************************************************************
 %*                                                                      *
 {-
 %************************************************************************
 %*                                                                      *
index a928470..d599381 100644 (file)
@@ -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
         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,
         checkDoAndIfThenElse,
         checkRecordSyntax,
+        checkValidDefaults,
         parseErrorSDoc,
 
         -- Help with processing exports
         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.Char
 
 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
+import Data.List       ( partition )
+import qualified Data.Set as Set ( fromList, difference, member )
 
 #include "HsVersions.h"
 
 
 #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
   = 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,
        ; 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 })) }
 
                                      , 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)
 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
            -> 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 }) }
        ; 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
 
 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
 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 })) }
 
        ; 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
                -> 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 }) }
        ; 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
 
 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.)
 -- 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
   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)
              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)
 
 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
    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))
                             (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)) _
 
    -- 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
 
 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
 
 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))
         -> 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)
 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")
 
     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
 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)
          -> (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
   | 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 :: 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
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity
index 8d74c8e..cdb2112 100644 (file)
@@ -668,11 +668,14 @@ mkSigTvFn :: [LSig Name] -> (Name -> [Name])
 mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
 mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
+    extractScopedTyVars :: LHsType Name -> [Name]
+    extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs
+    extractScopedTyVars _ = []
+
     env :: NameEnv [Name]
     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}
         -- 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 _ (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
   = 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
 
 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)]
   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
     expand_sig _ = []
 
     matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
index 02aab99..edf16b8 100644 (file)
@@ -257,11 +257,13 @@ rnExpr (RecordUpd expr rbinds _ _ _)
         ; return (RecordUpd expr' rbinds' [] [] [],
                   fvExpr `plusFV` fvRbinds) }
 
         ; 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
                              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
 
 rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
index dab2cce..02a45d0 100644 (file)
@@ -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)
     -- 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
     ValBindsIn _ val_sigs = val_binds
 
       -- the SrcSpan attached to the input should be the span of the
index a3e5faf..f99bc81 100644 (file)
@@ -559,7 +559,8 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
 
        ; let all_fvs = fvs `addOneFV` unLoc tycon'
        ; return (tycon',
 
        ; 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
                  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).
 
         -- 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.
         ; checkDupRdrNames sig_rdr_names_w_locs
                 -- Typechecker is responsible for checking that we only
                 -- give default-method bindings for things in this class.
index e0df3ec..d0877dc 100644 (file)
@@ -21,7 +21,8 @@ module RnTypes (
         warnContextQuantification, warnUnusedForAlls,
         bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
         warnContextQuantification, warnUnusedForAlls,
         bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
-        extractRdrKindSigVars, extractDataDefnKindVars, filterInScope
+        extractRdrKindSigVars, extractDataDefnKindVars,
+        extractWildcards, filterInScope
   ) where
 
 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
   ) where
 
 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
@@ -45,7 +46,7 @@ import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
 import Outputable
 import FastString
 import Maybes
 import Outputable
 import FastString
 import Maybes
-import Data.List        ( nub )
+import Data.List        ( nub, nubBy )
 import Control.Monad    ( unless, when )
 
 #include "HsVersions.h"
 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 :: 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
   = 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
 
            --   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
   = 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
 
     -- 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
   = 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
 
              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
 
 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) }
 
        ; (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
 --------------
 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
 
 \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)
 
          -> 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#
   = 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
         -- 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
   = 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
 
         -- 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) ]
                                                , 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 $
        ; 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
        ; 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)
       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 ([],[])
                                    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
 
 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
 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}
 \end{code}
index d0394d9..6cd4203 100644 (file)
@@ -31,6 +31,7 @@ import TcMType
 import ConLike
 import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
 import ConLike
 import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
+import Type( pprSigmaTypeExtraCts )
 import TyCon
 import TcType
 import TysPrim
 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
   = 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) }
       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
 
 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
 
         ; 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]
             { (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) }
 
        ; 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])]
 ------------------------
 mkEdges :: TcSigFun -> LHsBinds Name
         -> [(LHsBind Name, BKey, [BKey])]
@@ -455,7 +461,7 @@ mkEdges sig_fn binds
     ]
   where
     no_sig :: Name -> Bool
     ]
   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 ..]
 
 
     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
 --   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
             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 $
        ; 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
                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
 
        ; (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
        ; 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
 
 
 -- 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
   = 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
 
 
         -- 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"
         ; 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
 
         -- 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")
                       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]
 \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
 
         -- 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.)
 
                     -- 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)
                          -- 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) }
 
         ; 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)
 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
 -- 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] $
   = 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
             -- 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 }) }
                           , 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 ] $
 
 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}
 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]
 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]
        ; 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
 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 $
   = 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
 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' }
                           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
 
 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]
                                          (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
     -- 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
   = 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
 
 -------------------------------
 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
 
     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
 
     -- 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
 
     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)
 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}
 \end{code}
index 9b93815..6488c61 100644 (file)
@@ -151,8 +151,8 @@ canonicalize (CFunEqCan { cc_ev = ev
 
 canonicalize (CIrredEvCan { cc_ev = ev })
   = canIrred 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
 
 canEvNC :: CtEvidence -> TcS (StopOrContinue Ct)
 -- Called only for non-canonical EvVars
@@ -357,14 +357,16 @@ canIrred old_ev
            _                 -> continueWith $
                                 CIrredEvCan { cc_ev = new_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
   = 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}
                                      ; stopWith new_ev "Emit insoluble hole" }
            Stop ev s -> return (Stop ev s) } -- Found a cached copy; won't happen
 \end{code}
index 4e45d11..34409b2 100644 (file)
@@ -113,7 +113,7 @@ tcClassSigs clas sigs def_methods
        ; traceTc "tcClassSigs 2" (ppr clas)
        ; return (op_info, gen_dm_env) }
   where
        ; 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]
     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)
 
                  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))
            ; 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)
 
 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)
                             , L _ n <- ns ]
 
 lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
index 0ef74a1..cb83d1b 100644 (file)
@@ -27,7 +27,7 @@ module TcEnv(
         tcExtendKindEnv, tcExtendKindEnv2,
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
         tcExtendLetEnv,
         tcExtendKindEnv, tcExtendKindEnv2,
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
         tcExtendLetEnv,
-        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
+        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendIdEnv3,
         tcExtendIdBndrs, tcExtendGhciIdEnv,
 
         tcLookup, tcLookupLocated, tcLookupLocalIds, 
         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
 -- 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
        ; 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
 -- 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
   = 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 })
                                              , 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
           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
 --
 -- 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
 
 --          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)
   = 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
         ; 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] }
 
             , 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 } ) }
   | 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
        ; 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
 
     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
                          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
 
     get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]
       = tvs `unionVarSet` tyVarsOfType (tyVarKind tv) `extendVarSet` tv
index cd5879c..5c2e5fc 100644 (file)
@@ -33,7 +33,7 @@ import Var
 import VarSet
 import VarEnv
 import Bag
 import VarSet
 import VarEnv
 import Bag
-import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
+import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg, isWarning )
 import BasicTypes
 import Util
 import FastString
 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
        ; 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
        ; report_unsolved (Just binds_var) defer_errors defer_holes
-             warn_holes wanted
+             warn_holes warn_partial_sigs wanted
        ; getTcEvBinds binds_var }
 
 reportAllUnsolved :: WantedConstraints -> TcM ()
        ; 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
 -- 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
 
 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.
                 -> 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
   | 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_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 }
 
                             , 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
                                         -- 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
           , 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)
       [ -- 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
 
         -- 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
 
 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))
   | 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
 
 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 ()
     = 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 })
 ----------------
 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)))
              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
        ; (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
   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
     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
     | 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}
          ; flat_resttys <- mapM quickFlattenTy resttys
          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
 \end{code}
index d7af47c..a1d9b6a 100644 (file)
@@ -133,7 +133,8 @@ tcHole occ res_ty
       ; name <- newSysName occ
       ; let ev = mkLocalId name ty
       ; loc <- getCtLoc HoleOrigin
       ; 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}
       ; 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 }
 
                   , 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 ->
 
       ; (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
       ; 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)
 
 tcExpr (HsType ty) _
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
index dda2cf8..9b5ef8b 100644 (file)
@@ -1341,7 +1341,7 @@ gen_Data_binds dflags loc tycon
     genDataTyCon :: (LHsBind RdrName, LSig RdrName)
     genDataTyCon        --  $dT
       = (mkHsVarBind loc rdr_name rhs,
     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
       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,
     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
       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
 
         -- 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}
 
 %************************************************************************
 \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,
 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
 
   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)],
   = (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
   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,
 
 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
   where
     rdr_name = maxtag_RDR tycon
     sig_ty = HsCoreTy intTy
index 5ff622b..4d4484c 100644 (file)
@@ -718,7 +718,7 @@ zonkExpr env (ExprWithTySigOut e ty)
   = do { e' <- zonkLExpr env e
        ; return (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
 
 zonkExpr env (ArithSeq expr wit info)
   = do new_expr <- zonkExpr env expr
index 722d162..62611a3 100644 (file)
@@ -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
        ; 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
   = 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
     (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))
 
   | 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) }
 
        ; 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
 ---------------------------
 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
 \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
                                               -- 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
 
 -- 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
   = 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
                     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
   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
          -> 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
                  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
         -- 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
                 -- 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
 
         } 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!
                   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
         } }
   where
     mk_msg sig_ty tidy_env
index 8a15aca..acb5ae2 100644 (file)
@@ -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
         ; 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
 
             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
 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))
 instDeclCtxt2 :: Type -> SDoc
 instDeclCtxt2 dfun_ty
   = inst_decl_ctxt (ppr (mkClassPred cls tys))
index 233ae79..dfe9f21 100644 (file)
@@ -57,6 +57,10 @@ module TcMType (
   zonkEvVar, zonkWC, zonkFlats, zonkId, zonkCt, zonkSkolemInfo,
 
   tcGetGlobalTyVars,
   zonkEvVar, zonkWC, zonkFlats, zonkId, zonkCt, zonkSkolemInfo,
 
   tcGetGlobalTyVars,
+
+  --------------------------------
+  -- (Named) Wildcards
+  newWildcardVar, newWildcardVarMetaKind
   ) where
 
 #include "HsVersions.h"
   ) where
 
 #include "HsVersions.h"
@@ -103,7 +107,7 @@ kind_var_occ = mkOccName tvName "k"
 
 newMetaKindVar :: TcM TcKind
 newMetaKindVar = do { uniq <- newUnique
 
 newMetaKindVar :: TcM TcKind
 newMetaKindVar = do { uniq <- newUnique
-                    ; details <- newMetaDetails TauTv
+                    ; details <- newMetaDetails (TauTv False)
                     ; let kv = mkTcTyVar (mkKindName uniq) superKind details
                     ; return (mkTyVarTy kv) }
 
                     ; 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
   = 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) }
 
         ; 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
 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
 
 \begin{code}
 newFlexiTyVar :: Kind -> TcM TcTyVar
-newFlexiTyVar kind = newMetaTyVar TauTv kind
+newFlexiTyVar kind = newMetaTyVar (TauTv False) kind
 
 newFlexiTyVarTy  :: Kind -> TcM TcType
 newFlexiTyVarTy kind = do
 
 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
 -- 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
         ; 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)
                                  -- 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 }
               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]
 \end{code}
 
 Note [Zonking to Skolem]
@@ -988,3 +1009,32 @@ tidySkolemInfo env (UnifyForAllSkol skol_tvs ty)
 
 tidySkolemInfo env info = (env, info)
 \end{code}
 
 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}
index de60fcb..3b7b5df 100644 (file)
@@ -10,7 +10,7 @@ TcPat: Typechecking patterns
 
 module TcPat ( tcLetPat, TcSigFun, TcPragFun
              , TcSigInfo(..), TcPatSynInfo(..)
 
 module TcPat ( tcLetPat, TcSigFun, TcPragFun
              , TcSigInfo(..), TcPatSynInfo(..)
-             , findScopedTyVars
+             , findScopedTyVars, isPartialSig
              , LetBndrSpec(..), addInlinePrags, warnPrags
              , tcPat, tcPats, newNoSigLetBndr
              , addDataConStupidTheta, badFieldCon, polyPatSig ) where
              , 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]
 
                            -- 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_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_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
 
     }
   | TcPatSynInfo TcPatSynInfo
 
@@ -188,7 +201,7 @@ instance NamedThing TcSigInfo where
     getName (TcPatSynInfo tpsi) = patsig_name tpsi
 
 instance Outputable 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
         = 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
 
 instance Outputable TcPatSynInfo where
     ppr (TPSI{ patsig_name = name}) = ppr name
 
+isPartialSig :: TcSigInfo -> Bool
+isPartialSig = sig_partial
 \end{code}
 
 Note [Binding scoped type variables]
 \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
 -- 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
                          tc_lpat pat inner_ty penv thing_inside
-
         ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
 
 ------------------------
         ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
 
 ------------------------
index 23262f3..c9a5ba8 100644 (file)
@@ -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_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)
                             }
 
        ; (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   (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
       = 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"
     go1   (ConPatOut{})            = panic "ConPatOut in output of renamer"
     go1   (SigPatOut{})            = panic "SigPatOut in output of renamer"
     go1   (CoPat{})                = panic "CoPat in output of renamer"
index 7982e91..0ca12bf 100644 (file)
@@ -1699,12 +1699,12 @@ getGhciStepIO = do
         ioM    = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
 
         stepTy :: LHsType Name    -- Renamed, so needs all binders in place
         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)
                             (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)
     return step
 
 isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
index 146e1b7..a4e1e11 100644 (file)
@@ -1163,6 +1163,13 @@ captureUntouchables thing_inside
                 thing_inside
        ; return (res, untch') }
 
                 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) }
 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)
        }
        ; 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}
 
 
 \end{code}
 
 
index 9ec9395..e14733c 100644 (file)
@@ -49,7 +49,7 @@ module TcRnTypes(
         isEmptyCts, isCTyEqCan, isCFunEqCan,
         isCDictCan_Maybe, isCFunEqCan_maybe,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
         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,
         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,
         bumpSubGoalDepth, subGoalCounterValue, subGoalDepthExceeded,
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
         ctLocDepth, bumpCtLocDepth,
-        setCtLocOrigin, setCtLocEnv,
+        setCtLocOrigin, setCtLocEnv, setCtLocSpan,
         CtOrigin(..), pprCtOrigin,
         pushErrCtxt, pushErrCtxtSameOrigin,
 
         CtOrigin(..), pprCtOrigin,
         pushErrCtxt, pushErrCtxtSameOrigin,
 
@@ -84,7 +84,7 @@ module TcRnTypes(
         pprArising, pprArisingAt,
 
         -- Misc other types
         pprArising, pprArisingAt,
 
         -- Misc other types
-        TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds
+        TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds, HoleSort(..)
 
   ) where
 
 
   ) where
 
@@ -1065,9 +1065,15 @@ data Ct
 
   | CHoleCan {             -- Treated as an "insoluble" constraint
                            -- See Note [Insoluble constraints]
 
   | 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]
 \end{code}
 
 Note [Kind orientation for CTyEqCan]
@@ -1239,6 +1245,9 @@ isHoleCt:: Ct -> Bool
 isHoleCt (CHoleCan {}) = True
 isHoleCt _ = False
 
 isHoleCt (CHoleCan {}) = True
 isHoleCt _ = False
 
+isTypedHoleCt :: Ct -> Bool
+isTypedHoleCt (CHoleCan { cc_hole = ExprHole }) = True
+isTypedHoleCt _ = False
 \end{code}
 
 \begin{code}
 \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 :: 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
                || 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
 
 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 }
 
 bumpCtLocDepth :: SubGoalCounter -> CtLoc -> CtLoc
 bumpCtLocDepth cnt loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth cnt d }
 
index cd4776f..dc150c5 100644 (file)
@@ -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
 --  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
         ; let id  = mkLocalId name id_ty
               tvs = map snd tv_prs
                     -- tcHsPatSigType returns (Name,TyVar) pairs
index 4bd3393..9355e3b 100644 (file)
@@ -1552,7 +1552,7 @@ instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs)
 instFlexiTcSHelper :: Name -> Kind -> TcM TcType
 instFlexiTcSHelper tvname kind
   = do { uniq <- TcM.newUnique
 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)) }
 
        ; let name = setNameUnique tvname uniq
        ; return (mkTyVarTy (mkTcTyVar name kind details)) }
 
index 300b18c..ca69856 100644 (file)
@@ -487,7 +487,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
     do  { _ <- tcHsContext ctxt
         ; mapM_ (wrapLocM kc_sig)     sigs }
   where
     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 ()
 
     kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty)
     kc_sig _                    = return ()
 
index c2c23bd..1d3ee40 100644 (file)
@@ -340,9 +340,11 @@ instance Outputable MetaDetails where
   ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
 
 data MetaInfo
   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
                    -- 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.
 
    | 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
   = 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)
 
 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
   = 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
                                      || isOpenTypeKind kind
                                           -- Note [OpenTypeKind accepts foralls]
       _other                         -> True
index 32dda3c..e1f4293 100644 (file)
@@ -923,8 +923,8 @@ checkValidInstance ctxt hs_type ty
 
         -- The location of the "head" of the instance
     head_loc = case hs_type of
 
         -- 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]
 \end{code}
 
 Note [Paterson conditions]
index 01ec26c..ca77adc 100644 (file)
@@ -132,7 +132,7 @@ module Type (
         pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType,
         pprTheta, pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprSourceTyCon,
         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,
 
         -- * 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
 
 -- 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
 
 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
 
 \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
 -- meta kind var constructors and functions are in TcType
 
 type SimpleKind = Kind
index ef035bb..c2f8a14 100644 (file)
@@ -32,7 +32,7 @@ module TypeRep (
 
         -- Pretty-printing
         pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
 
         -- Pretty-printing
         pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
-        pprTyThing, pprTyThingCategory, pprSigmaType,
+        pprTyThing, pprTyThingCategory, pprSigmaType, pprSigmaTypeExtraCts,
         pprTheta, pprForAll, pprUserForAll,
         pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprTyLit, suppressKinds,
         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)
 
     --            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
 ------------------
 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
 
 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
     -- 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]
 
 ppr_tvar :: TyVar -> SDoc
 ppr_tvar tv  -- Note [Infix type variables]
@@ -613,13 +618,16 @@ ppr_tylit _ tl =
     StrTyLit s -> text (show s)
 
 -------------------
     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
   = 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
         , 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
     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]
 
 pprUserForAll :: [TyVar] -> SDoc
 -- Print a user-level forall; see Note [WHen to print foralls]
index 56ebcd3..9ddd271 100644 (file)
             <entry><option>-XNoNamedFieldPuns</option></entry>
           </row>
           <row>
             <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>
             <entry><option>-XNegativeLiterals</option></entry>
             <entry>Enable support for <link linkend="negative-literals">negative literals</link>.</entry>
             <entry>dynamic</entry>
             <entry><option>-XNoParallelListComp</option></entry>
           </row>
           <row>
             <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>
             <entry><option>-XPatternGuards</option></entry>
             <entry>Enable <link linkend="pattern-guards">pattern guards</link>.</entry>
             <entry>dynamic</entry>
             <entry><option>-fno-warn-typed-holes</option></entry>
           </row>
 
             <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>
         </tbody>
       </tgroup>
     </informaltable>
index 5ed99ba..586b31d 100644 (file)
@@ -8530,6 +8530,293 @@ This ensures that an unbound identifier is never reported with a too polymorphic
 </para>
 
 </sect1>
 </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 &lsquo;_&rsquo; with type: Bool
+    To use the inferred type, enable PartialTypeSignatures
+    In the type signature for &lsquo;not'&rsquo;: 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 &lsquo;_a&rsquo; with actual type &lsquo;Bool&rsquo;
+      &lsquo;_a&rsquo; 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 &lsquo;foo&rsquo;: 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 &lsquo;_a&rsquo; with type: Bool
+    In the type signature for &lsquo;foo&rsquo;: _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 &lsquo;_&rsquo; with inferred constraints: (Enum a, Eq a, Show a)
+    To use the inferred type, enable PartialTypeSignatures
+    In the type signature for &lsquo;arbitCs&rsquo;: _ => 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 &lsquo;_&rsquo; with inferred constraints: (Eq a, Show a)
+    To use the inferred type, enable PartialTypeSignatures
+    In the type signature for &lsquo;arbitCs'&rsquo;: (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 &lsquo;_&rsquo; with inferred constraints: ()
+    To use the inferred type, enable PartialTypeSignatures
+    In the type signature for &lsquo;noCs&rsquo;: _ => 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">
 <!-- ==================== Deferring type errors =================  -->
 
 <sect1 id="defer-type-errors">
index 309be8c..396af6c 100644 (file)
@@ -1178,6 +1178,24 @@ test.hs:(5,4)-(6,7):
       </varlistentry>
 
       <varlistentry>
       </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>
         <term><option>-fhelpful-errors</option>:</term>
         <listitem>
           <indexterm><primary><option>-fhelpful-errors</option></primary>
index f8b2f98..320238d 100644 (file)
@@ -35,7 +35,9 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRuleTransitional",
                              "DeriveAnyClass",
                              "JavaScriptFFI",
                              "AlternativeLayoutRuleTransitional",
                              "DeriveAnyClass",
                              "JavaScriptFFI",
-                             "PatternSynonyms"]
+                             "PatternSynonyms",
+                             "PartialTypeSignatures",
+                             "NamedWildcards"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/partial-sigs/Makefile b/testsuite/tests/partial-sigs/Makefile
new file mode 100644 (file)
index 0000000..9a36a1c
--- /dev/null
@@ -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 (file)
index 0000000..476bf55
--- /dev/null
@@ -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 (file)
index 0000000..74b1ae1
--- /dev/null
@@ -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 (file)
index 0000000..39b7fe1
--- /dev/null
@@ -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 (file)
index 0000000..b0952b4
--- /dev/null
@@ -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 (file)
index 0000000..767c2e6
--- /dev/null
@@ -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 (file)
index 0000000..f902a80
--- /dev/null
@@ -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 (file)
index 0000000..a1486bc
--- /dev/null
@@ -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 (file)
index 0000000..f68e6ef
--- /dev/null
@@ -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 (file)
index 0000000..6afba46
--- /dev/null
@@ -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 (file)
index 0000000..be7cc05
--- /dev/null
@@ -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 (file)
index 0000000..5de904a
--- /dev/null
@@ -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 (file)
index 0000000..8e66994
--- /dev/null
@@ -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 (file)
index 0000000..79ceee2
--- /dev/null
@@ -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 (file)
index 0000000..ec1703a
--- /dev/null
@@ -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 (file)
index 0000000..f27f8e0
--- /dev/null
@@ -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 (file)
index 0000000..3d8f949
--- /dev/null
@@ -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 (file)
index 0000000..23223b7
--- /dev/null
@@ -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 (file)
index 0000000..fbcadde
--- /dev/null
@@ -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 (file)
index 0000000..f192c02
--- /dev/null
@@ -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 (file)
index 0000000..fb95845
--- /dev/null
@@ -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 (file)
index 0000000..6afcad1
--- /dev/null
@@ -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 (file)
index 0000000..9fda9ec
--- /dev/null
@@ -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 (file)
index 0000000..39337f5
--- /dev/null
@@ -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 (file)
index 0000000..bff0e84
--- /dev/null
@@ -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 (file)
index 0000000..170af64
--- /dev/null
@@ -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 (file)
index 0000000..269a611
--- /dev/null
@@ -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 (file)
index 0000000..3c82fa2
--- /dev/null
@@ -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 (file)
index 0000000..90bcb57
--- /dev/null
@@ -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 (file)
index 0000000..3d91e3a
--- /dev/null
@@ -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 (file)
index 0000000..ce7c7a3
--- /dev/null
@@ -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 (file)
index 0000000..bce424a
--- /dev/null
@@ -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 (file)
index 0000000..3d8f949
--- /dev/null
@@ -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 (file)
index 0000000..3be7bea
--- /dev/null
@@ -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 (file)
index 0000000..3d8f949
--- /dev/null
@@ -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 (file)
index 0000000..f6c6a91
--- /dev/null
@@ -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 (file)
index 0000000..15eb30d
--- /dev/null
@@ -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 (file)
index 0000000..168d4db
--- /dev/null
@@ -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 (file)
index 0000000..8c28c5b
--- /dev/null
@@ -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 (file)
index 0000000..56b9f35
--- /dev/null
@@ -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 (file)
index 0000000..f4df3cb
--- /dev/null
@@ -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