summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/deSugar/Check.hs2
-rw-r--r--compiler/deSugar/Coverage.hs13
-rw-r--r--compiler/deSugar/Desugar.hs8
-rw-r--r--compiler/deSugar/DsArrows.hs2
-rw-r--r--compiler/deSugar/DsExpr.hs4
-rw-r--r--compiler/deSugar/DsMeta.hs189
-rw-r--r--compiler/deSugar/Match.hs4
-rw-r--r--compiler/deSugar/PmExpr.hs2
-rw-r--r--compiler/hsSyn/Convert.hs63
-rw-r--r--compiler/hsSyn/HsDecls.hs85
-rw-r--r--compiler/hsSyn/HsExpr.hs22
-rw-r--r--compiler/hsSyn/HsExtension.hs40
-rw-r--r--compiler/hsSyn/HsPat.hs18
-rw-r--r--compiler/hsSyn/HsTypes.hs22
-rw-r--r--compiler/hsSyn/HsUtils.hs8
-rw-r--r--compiler/main/HscMain.hs2
-rw-r--r--compiler/main/HscStats.hs3
-rw-r--r--compiler/parser/Parser.y177
-rw-r--r--compiler/parser/RdrHsSyn.hs53
-rw-r--r--compiler/rename/RnBinds.hs2
-rw-r--r--compiler/rename/RnExpr.hs14
-rw-r--r--compiler/rename/RnPat.hs6
-rw-r--r--compiler/rename/RnSource.hs123
-rw-r--r--compiler/rename/RnTypes.hs53
-rw-r--r--compiler/rename/RnUtils.hs5
-rw-r--r--compiler/typecheck/TcAnnotations.hs1
-rw-r--r--compiler/typecheck/TcEnv.hs1
-rw-r--r--compiler/typecheck/TcExpr.hs14
-rw-r--r--compiler/typecheck/TcGenDeriv.hs5
-rw-r--r--compiler/typecheck/TcHsSyn.hs30
-rw-r--r--compiler/typecheck/TcInstDcls.hs11
-rw-r--r--compiler/typecheck/TcPat.hs4
-rw-r--r--compiler/typecheck/TcPatSyn.hs4
-rw-r--r--compiler/typecheck/TcRnDriver.hs2
-rw-r--r--compiler/typecheck/TcRnTypes.hs2
-rw-r--r--compiler/typecheck/TcRules.hs100
-rw-r--r--compiler/typecheck/TcSplice.hs25
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs74
-rw-r--r--docs/users_guide/glasgow_exts.rst68
-rw-r--r--docs/users_guide/using-warnings.rst20
-rw-r--r--ghc/GHCi/UI.hs4
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs21
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs57
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs41
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs12
-rw-r--r--libraries/template-haskell/changelog.md12
-rw-r--r--testsuite/tests/ghc-api/annotations/stringSource.hs2
-rw-r--r--testsuite/tests/ghc-api/annotations/t11430.hs6
-rw-r--r--testsuite/tests/indexed-types/should_compile/ExplicitForAllFams1.hs31
-rw-r--r--testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.hs39
-rw-r--r--testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr12
-rw-r--r--testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr14
-rw-r--r--testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr14
-rw-r--r--testsuite/tests/indexed-types/should_compile/all.T3
-rw-r--r--testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.hs23
-rw-r--r--testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.stderr17
-rw-r--r--testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.hs8
-rw-r--r--testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr8
-rw-r--r--testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs26
-rw-r--r--testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr44
-rw-r--r--testsuite/tests/indexed-types/should_fail/all.T4
-rw-r--r--testsuite/tests/parser/should_compile/DumpParsedAst.stderr2
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr3
-rw-r--r--testsuite/tests/parser/should_compile/KindSigs.stderr1
-rw-r--r--testsuite/tests/rename/should_compile/ExplicitForAllRules1.hs45
-rw-r--r--testsuite/tests/rename/should_compile/ExplicitForAllRules1.stderr4
-rw-r--r--testsuite/tests/rename/should_compile/T2600.hs19
-rw-r--r--testsuite/tests/rename/should_compile/T2600.stderr10
-rw-r--r--testsuite/tests/rename/should_compile/all.T4
-rw-r--r--testsuite/tests/rename/should_fail/ExplicitForAllRules2.hs12
-rw-r--r--testsuite/tests/rename/should_fail/ExplicitForAllRules2.stderr10
-rw-r--r--testsuite/tests/rename/should_fail/all.T2
-rw-r--r--testsuite/tests/th/ClosedFam2TH.hs6
-rw-r--r--testsuite/tests/th/T12503.hs2
-rw-r--r--testsuite/tests/th/T12646.stderr5
-rw-r--r--testsuite/tests/th/T13618.hs8
-rw-r--r--testsuite/tests/th/T5886a.hs4
-rw-r--r--testsuite/tests/th/T6018th.hs30
-rw-r--r--testsuite/tests/th/T6018th.stderr6
-rw-r--r--testsuite/tests/th/T7532a.hs2
-rw-r--r--testsuite/tests/th/T8884.stderr5
-rw-r--r--testsuite/tests/th/T8953.stderr10
-rw-r--r--testsuite/tests/th/TH_ExplicitForAllRules.hs9
-rw-r--r--testsuite/tests/th/TH_ExplicitForAllRules.stdout3
-rw-r--r--testsuite/tests/th/TH_ExplicitForAllRules_a.hs10
-rw-r--r--testsuite/tests/th/TH_reifyExplicitForAllFams.hs35
-rw-r--r--testsuite/tests/th/TH_reifyExplicitForAllFams.stderr16
-rw-r--r--testsuite/tests/th/all.T4
-rw-r--r--utils/ghctags/Main.hs2
m---------utils/haddock0
90 files changed, 1411 insertions, 537 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 4cd5601c9b..cba86dfe4d 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -973,7 +973,7 @@ translatePat fam_insts pat = case pat of
g = PmGrd [PmVar (unLoc lid)] e
return (ps ++ [g])
- SigPat _ty p -> translatePat fam_insts (unLoc p)
+ SigPat _ p _ty -> translatePat fam_insts (unLoc p)
-- See Note [Translate CoPats]
CoPat _ wrapper p ty
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 99ba96755f..7ca18c7d2e 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -500,9 +500,9 @@ addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
(addTickMatchGroup True mgs)
addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
(addTickLHsExpr e2)
-addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty)
- (addTickLHsExprNever e)
-
+addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
+ (addTickLHsExprNever e)
+ (return ty)
addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp
@@ -578,11 +578,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) }
-addTickHsExpr (ExprWithTySig ty e) =
- liftM2 ExprWithTySig
- (return ty)
+addTickHsExpr (ExprWithTySig x e ty) =
+ liftM3 ExprWithTySig
+ (return x)
(addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures
+ (return ty)
addTickHsExpr (ArithSeq ty wit arith_seq) =
liftM3 ArithSeq
(return ty)
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index c1e728b734..c7973ca4f3 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -379,7 +379,11 @@ Reason
-}
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (L loc (HsRule _ name rule_act vars lhs rhs))
+dsRule (L loc (HsRule { rd_name = name
+ , rd_act = rule_act
+ , rd_tmvs = vars
+ , rd_lhs = lhs
+ , rd_rhs = rhs }))
= putSrcSpanDs loc $
do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
@@ -497,7 +501,7 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList.
That keeps the desugaring of list comprehensions simple too.
Nor do we want to warn of conversion identities on the LHS;
-the rule is precisly to optimise them:
+the rule is precisely to optimise them:
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
Note [Desugaring coerce as cast]
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index c69d7495d9..8837eeae40 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -1224,7 +1224,7 @@ collectl (L _ pat) bndrs
go (NPat {}) = bndrs
go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
- go (SigPat _ pat) = collectl pat bndrs
+ go (SigPat _ pat _) = collectl pat bndrs
go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index f9ee3b4cb8..bdba4e06eb 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -257,7 +257,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap?
-- See Wrinkle in Note [Detecting forced eta expansion]
-> HsExpr GhcTc -> DsM CoreExpr
ds_expr _ (HsPar _ e) = dsLExpr e
-ds_expr _ (ExprWithTySig _ e) = dsLExpr e
+ds_expr _ (ExprWithTySig _ e _) = dsLExpr e
ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
ds_expr w (HsConLikeOut _ con) = dsConLike w con
@@ -302,7 +302,7 @@ ds_expr _ e@(HsApp _ fun arg)
; dsWhenNoErrs (dsLExprNoLP arg)
(\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
-ds_expr _ (HsAppType _ e)
+ds_expr _ (HsAppType _ e _)
-- ignore type arguments here; they're in the wrappers instead at this point
= dsLExpr e
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d25a7cfd06..dfcfc3d9d6 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -310,7 +310,7 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- repDataDefn tc1 bndrs Nothing defn
+ repDataDefn tc1 (Left bndrs) defn
; return (Just (loc, dec)) }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
@@ -344,11 +344,14 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
-------------------------
-repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
- -> Maybe (Core [TH.TypeQ])
+repDataDefn :: Core TH.Name
+ -> Either (Core [TH.TyVarBndrQ])
+ -- the repTyClD case
+ (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+ -- the repDataFamInstD case
-> HsDataDefn GhcRn
-> DsM (Core TH.DecQ)
-repDataDefn tc bndrs opt_tys
+repDataDefn tc opts
(HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
, dd_cons = cons, dd_derivs = mb_derivs })
= do { cxt1 <- repLContext cxt
@@ -356,7 +359,7 @@ repDataDefn tc bndrs opt_tys
; case (new_or_data, cons) of
(NewType, [con]) -> do { con' <- repC con
; ksig' <- repMaybeLTy ksig
- ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
+ ; repNewtype cxt1 tc opts ksig' con'
derivs1 }
(NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
<+> pprQuotedList
@@ -364,10 +367,10 @@ repDataDefn tc bndrs opt_tys
(DataType, _) -> do { ksig' <- repMaybeLTy ksig
; consL <- mapM repC cons
; cons1 <- coreList conQTyConName consL
- ; repData cxt1 tc bndrs opt_tys ksig' cons1
+ ; repData cxt1 tc opts ksig' cons1
derivs1 }
}
-repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn"
+repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> LHsType GhcRn
@@ -455,14 +458,17 @@ repAssocTyFamDefaults = mapM rep_deflt
-- very like repTyFamEqn, but different in the details
rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
rep_deflt (L _ (FamEqn { feqn_tycon = tc
- , feqn_pats = bndrs
+ , feqn_bndrs = bndrs
+ , feqn_pats = tys
, feqn_rhs = rhs }))
- = addTyClTyVarBinds bndrs $ \ _ ->
+ = addTyClTyVarBinds tys $ \ _ ->
do { tc1 <- lookupLOcc tc
- ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
+ ; no_bndrs <- ASSERT( isNothing bndrs )
+ coreNothingList tyVarBndrQTyConName
+ ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs
- ; eqn1 <- repTySynEqn tys2 rhs1
+ ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
; repTySynInst tc1 eqn1 }
rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
@@ -544,17 +550,21 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (HsIB { hsib_ext = var_names
- , hsib_body = FamEqn { feqn_pats = tys
+ , hsib_body = FamEqn { feqn_bndrs = mb_bndrs
+ , feqn_pats = tys
, feqn_rhs = rhs }})
= do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk
- , hsq_explicit = [] }
+ , hsq_explicit = fromMaybe [] mb_bndrs }
; addTyClTyVarBinds hs_tvs $ \ _ ->
- do { tys1 <- repLTys tys
+ do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+ repTyVarBndr
+ mb_bndrs
+ ; tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs
- ; repTySynEqn tys2 rhs1 } }
+ ; repTySynEqn mb_bndrs1 tys2 rhs1 } }
repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
@@ -562,16 +572,20 @@ repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_eqn =
(HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name
+ , feqn_bndrs = mb_bndrs
, feqn_pats = tys
, feqn_rhs = defn }})})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk
- , hsq_explicit = [] }
- ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
- do { tys1 <- repList typeQTyConName repLTy tys
- ; repDataDefn tc bndrs (Just tys1) defn } }
+ , hsq_explicit = fromMaybe [] mb_bndrs }
+ ; addTyClTyVarBinds hs_tvs $ \ _ ->
+ do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+ repTyVarBndr
+ mb_bndrs
+ ; tys1 <- repList typeQTyConName repLTy tys
+ ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
= panic "repDataFamInstD"
repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
@@ -633,18 +647,29 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
repFixD (L _ (XFixitySig _)) = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRuleD (L loc (HsRule _ n act bndrs lhs rhs))
- = do { let bndr_names = concatMap ruleBndrNames bndrs
- ; ss <- mkGenSyms bndr_names
- ; rule1 <- addBinds ss $
- do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
- ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
- ; act' <- repPhases act
- ; lhs' <- repLE lhs
- ; rhs' <- repLE rhs
- ; repPragRule n' bndrs' lhs' rhs' act' }
- ; rule2 <- wrapGenSyms ss rule1
- ; return (loc, rule2) }
+repRuleD (L loc (HsRule { rd_name = n
+ , rd_act = act
+ , rd_tyvs = ty_bndrs
+ , rd_tmvs = tm_bndrs
+ , rd_lhs = lhs
+ , rd_rhs = rhs }))
+ = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+ do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
+ ; ss <- mkGenSyms tm_bndr_names
+ ; rule <- addBinds ss $
+ do { ty_bndrs' <- case ty_bndrs of
+ Nothing -> coreNothingList tyVarBndrQTyConName
+ Just _ -> coreJustList tyVarBndrQTyConName ex_bndrs
+ ; tm_bndrs' <- repList ruleBndrQTyConName
+ repRuleBndr
+ tm_bndrs
+ ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
+ ; act' <- repPhases act
+ ; lhs' <- repLE lhs
+ ; rhs' <- repLE rhs
+ ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
+ ; wrapGenSyms ss rule }
+ ; return (loc, rule) }
repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
@@ -936,15 +961,10 @@ rep_complete_sig :: Located [Located Name]
-> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_complete_sig (L _ cls) mty loc
- = do { mty' <- rep_maybe_name mty
+ = do { mty' <- repMaybe nameTyConName lookupLOcc mty
; cls' <- repList nameTyConName lookupLOcc cls
; sig <- repPragComplete cls' mty'
; return [(loc, sig)] }
- where
- rep_maybe_name Nothing = coreNothing nameTyConName
- rep_maybe_name (Just n) = do
- cn <- lookupLOcc n
- coreJust nameTyConName cn
-------------------------------------------------------
-- Types
@@ -1154,11 +1174,7 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
-- | Represent a type wrapped in a Maybe
repMaybeLTy :: Maybe (LHsKind GhcRn)
-> DsM (Core (Maybe TH.TypeQ))
-repMaybeLTy Nothing =
- do { coreNothing kindQTyConName }
-repMaybeLTy (Just ki) =
- do { ki' <- repLTy ki
- ; coreJust kindQTyConName ki' }
+repMaybeLTy = repMaybe kindQTyConName repLTy
repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
repRole (L _ (Just Nominal)) = rep2 nominalRName []
@@ -1228,9 +1244,9 @@ repE (HsLamCase _ (MG { mg_alts = L _ ms }))
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType t e) = do { a <- repLE e
- ; s <- repLTy (hswc_body t)
- ; repAppType a s }
+repE (HsAppType _ e t) = do { a <- repLE e
+ ; s <- repLTy (hswc_body t)
+ ; repAppType a s }
repE (OpApp _ e1 op e2) =
do { arg1 <- repLE e1;
@@ -1303,7 +1319,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
-repE (ExprWithTySig ty e)
+repE (ExprWithTySig _ e ty)
= do { e1 <- repLE e
; t1 <- repHsSigWcType ty
; repSigExp e1 t1 }
@@ -1772,9 +1788,9 @@ repP (ConPatIn dc details)
repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
-repP (SigPat t p) = do { p' <- repLP p
- ; t' <- repLTy (hsSigWcType t)
- ; repPsig p' t' }
+repP (SigPat _ p t) = do { p' <- repLP p
+ ; t' <- repLTy (hsSigWcType t)
+ ; repPsig p' t' }
repP (SplicePat _ splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
@@ -2146,24 +2162,28 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
-repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
- -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
- -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
-repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
+repData :: Core TH.CxtQ -> Core TH.Name
+ -> Either (Core [TH.TyVarBndrQ])
+ (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+ -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
+ -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
-repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
- (MkC derivs)
- = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
-
-repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
- -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
- -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
-repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
+repData (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
+ (MkC cons) (MkC derivs)
+ = rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name
+ -> Either (Core [TH.TyVarBndrQ])
+ (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+ -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
+ -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
-repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
- (MkC derivs)
- = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
+ (MkC con) (MkC derivs)
+ = rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs]
repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> Core TH.TypeQ -> DsM (Core TH.DecQ)
@@ -2253,10 +2273,11 @@ repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
-repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
- -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
-repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
- = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
+repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
+ -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
+ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+ = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
@@ -2287,9 +2308,10 @@ repClosedFamilyD :: Core TH.Name
repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
= rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
-repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
-repTySynEqn (MkC lhs) (MkC rhs)
- = rep2 tySynEqnName [lhs, rhs]
+repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
+ Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
+ = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
@@ -2591,6 +2613,11 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------------- Maybe ------------------
+repMaybe :: Name -> (a -> DsM (Core b))
+ -> Maybe a -> DsM (Core (Maybe b))
+repMaybe tc_name _ Nothing = coreNothing tc_name
+repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
+
-- | Construct Core expression for Nothing of a given type name
coreNothing :: Name -- ^ Name of the TyCon of the element type
-> DsM (Core (Maybe a))
@@ -2613,6 +2640,26 @@ coreJust' :: Type -- ^ The element type
-> Core a -> Core (Maybe a)
coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
+------------------- Maybe Lists ------------------
+
+repMaybeList :: Name -> (a -> DsM (Core b))
+ -> Maybe [a] -> DsM (Core (Maybe [b]))
+repMaybeList tc_name _ Nothing = coreNothingList tc_name
+repMaybeList tc_name f (Just args)
+ = do { elt_ty <- lookupType tc_name
+ ; args1 <- mapM f args
+ ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
+
+coreNothingList :: Name -> DsM (Core (Maybe [a]))
+coreNothingList tc_name
+ = do { elt_ty <- lookupType tc_name
+ ; return $ coreNothing' (mkListTy elt_ty) }
+
+coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
+coreJustList tc_name args
+ = do { elt_ty <- lookupType tc_name
+ ; return $ coreJust' (mkListTy elt_ty) args }
+
------------ Literals & Variables -------------------
coreIntLit :: Int -> DsM (Core Int)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index ec982f6b25..e4a8bad525 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -402,7 +402,7 @@ tidy1 :: Id -- The Id being scrutinised
-- list patterns, etc) and returns any created bindings in the wrapper.
tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat)
-tidy1 v (SigPat _ pat) = tidy1 v (unLoc pat)
+tidy1 v (SigPat _ pat _) = tidy1 v (unLoc pat)
tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
@@ -480,7 +480,7 @@ tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
-tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index fbacb989a1..7fa941add1 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -292,7 +292,7 @@ hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySig _ e _) = lhsExprToPmExpr e
hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index af2c6034a9..8b12a78ed3 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -294,8 +294,8 @@ cvtDec (DataFamilyD tc tvs kind)
; returnJustL $ TyClD noExt $ FamDecl noExt $
FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
-cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
- = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
+cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs)
+ = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
@@ -309,12 +309,14 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
{ dfid_ext = noExt
, dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
FamEqn { feqn_ext = noExt
- , feqn_tycon = tc', feqn_pats = typats'
+ , feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
+ , feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
-cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
- = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
+cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
+ = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
@@ -327,7 +329,9 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
{ dfid_ext = noExt
, dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
FamEqn { feqn_ext = noExt
- , feqn_tycon = tc', feqn_pats = typats'
+ , feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
+ , feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
@@ -407,12 +411,14 @@ cvtDec (TH.ImplicitParamBindD _ _)
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
-cvtTySynEqn tc (TySynEqn lhs rhs)
- = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs
+cvtTySynEqn tc (TySynEqn mb_bndrs lhs rhs)
+ = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
+ ; lhs' <- mapM (wrap_apps <=< cvtType) lhs
; rhs' <- cvtType rhs
; returnL $ mkHsImplicitBndrs
$ FamEqn { feqn_ext = noExt
, feqn_tycon = tc
+ , feqn_bndrs = mb_bndrs'
, feqn_pats = lhs'
, feqn_fixity = Prefix
, feqn_rhs = rhs' } }
@@ -450,15 +456,17 @@ cvt_tycl_hdr cxt tc tvs
; return (cxt', tc', tvs')
}
-cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
+cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> Maybe [TH.TyVarBndr] -> [TH.Type]
-> CvtM ( LHsContext GhcPs
, Located RdrName
+ , Maybe [LHsTyVarBndr GhcPs]
, HsTyPats GhcPs)
-cvt_tyinst_hdr cxt tc tys
- = do { cxt' <- cvtContext cxt
- ; tc' <- tconNameL tc
- ; tys' <- mapM (wrap_apps <=< cvtType) tys
- ; return (cxt', tc', tys') }
+cvt_tyinst_hdr cxt tc bndrs tys
+ = do { cxt' <- cvtContext cxt
+ ; tc' <- tconNameL tc
+ ; bndrs' <- traverse (mapM cvt_tv) bndrs
+ ; tys' <- mapM (wrap_apps <=< cvtType) tys
+ ; return (cxt', tc', bndrs', tys') }
----------------
cvt_tyfam_head :: TypeFamilyHead
@@ -707,17 +715,26 @@ cvtPragmaD (SpecialiseInstP ty)
; returnJustL $ Hs.SigD noExt $
SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
-cvtPragmaD (RuleP nm bndrs lhs rhs phases)
+cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
; let act = cvtPhases phases AlwaysActive
- ; bndrs' <- mapM cvtRuleBndr bndrs
+ ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs
+ ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
; lhs' <- cvtl lhs
; rhs' <- cvtl rhs
; returnJustL $ Hs.RuleD noExt
- $ HsRules noExt (SourceText "{-# RULES")
- [noLoc $ HsRule noExt (noLoc (quotedSourceText nm,nm'))
- act bndrs' lhs' rhs']
- }
+ $ HsRules { rds_ext = noExt
+ , rds_src = SourceText "{-# RULES"
+ , rds_rules = [noLoc $
+ HsRule { rd_ext = noExt
+ , rd_name = (noLoc (quotedSourceText nm,nm'))
+ , rd_act = act
+ , rd_tyvs = ty_bndrs'
+ , rd_tmvs = tm_bndrs'
+ , rd_lhs = lhs'
+ , rd_rhs = rhs' }] }
+
+ }
cvtPragmaD (AnnP target exp)
= do { exp' <- cvtl exp
@@ -838,7 +855,7 @@ cvtl e = wrapL (cvt e)
; t' <- cvtType t
; tp <- wrap_apps t'
; let tp' = parenthesizeHsType appPrec tp
- ; return $ HsAppType (mkHsWildCardBndrs tp') e' }
+ ; return $ HsAppType noExt e' (mkHsWildCardBndrs tp') }
cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its
-- own expression to avoid pretty-printing
-- oddities that can result from zero-argument
@@ -923,7 +940,7 @@ cvtl e = wrapL (cvt e)
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
; let pe = parenthesizeHsExpr sigPrec e'
- ; return $ ExprWithTySig (mkLHsSigWcType t') pe }
+ ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -1201,7 +1218,7 @@ cvtp (ListP ps) = do { ps' <- cvtPats ps
; return
$ ListPat noExt ps'}
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
- ; return $ SigPat (mkLHsSigWcType t') p' }
+ ; return $ SigPat noExt p' (mkLHsSigWcType t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat noExt e' p'}
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 55f3b73686..0ff36aa712 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -48,7 +48,7 @@ module HsDecls (
-- ** Deriving strategies
DerivStrategy(..), LDerivStrategy, derivStrategyName,
-- ** @RULE@ declarations
- LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..),
+ LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
@@ -1528,9 +1528,12 @@ type HsTyPats pass = [LHsType pass]
{- Note [Family instance declaration binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For ordinary data/type family instances, the feqn_pats field of FamEqn stores
-the LHS type (and kind) patterns. These type patterns can of course contain
-type (and kind) variables, which are bound in the hsib_vars field of the
-HsImplicitBndrs in FamInstEqn. Note in particular
+the LHS type (and kind) patterns. Any type (and kind) variables contained
+in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs
+in FamInstEqn depending on whether or not an explicit forall is present. In
+the case of an explicit forall, the hsib_vars only includes kind variables not
+bound in the forall. Otherwise, all type (and kind) variables are bound in
+the hsib_vars. In the latter case, note that in particular
* The hsib_vars *includes* any anonymous wildcards. For example
type instance F a _ = a
@@ -1616,6 +1619,7 @@ data FamEqn pass pats rhs
= FamEqn
{ feqn_ext :: XCFamEqn pass pats rhs
, feqn_tycon :: Located (IdP pass)
+ , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars
, feqn_pats :: pats
, feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
, feqn_rhs :: rhs
@@ -1701,10 +1705,11 @@ ppr_instance_keyword NotTopLevel = empty
ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
=> TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+ , feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }})
- = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
+ = pprFamInstLHS tycon bndrs pats fixity [] Nothing <+> equals <+> ppr rhs
ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
@@ -1726,13 +1731,14 @@ pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
=> TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
+ , feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = defn }}})
= pp_data_defn pp_hdr defn
where
pp_hdr ctxt = ppr_instance_keyword top_lvl
- <+> pprFamInstLHS tycon pats fixity ctxt Nothing
+ <+> pprFamInstLHS tycon bndrs pats fixity ctxt Nothing
-- No need to pass an explicit kind signature to
-- pprFamInstLHS here, since pp_data_defn already
-- pretty-prints that. See #14817.
@@ -1755,14 +1761,16 @@ pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
pprFamInstLHS :: (OutputableBndrId (GhcPass p))
=> Located (IdP (GhcPass p))
+ -> Maybe [LHsTyVarBndr (GhcPass p)]
-> HsTyPats (GhcPass p)
-> LexicalFixity
-> HsContext (GhcPass p)
-> Maybe (LHsKind (GhcPass p))
-> SDoc
-pprFamInstLHS thing typats fixity context mb_kind_sig
+pprFamInstLHS thing bndrs typats fixity context mb_kind_sig
-- explicit type patterns
- = hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ]
+ = hsep [ pprHsContext context, pprHsExplicitForAll bndrs
+ , pp_pats typats, pp_kind_sig ]
where
pp_pats (patl:patr:pats)
| Infix <- fixity
@@ -2139,24 +2147,27 @@ type LRuleDecl pass = Located (RuleDecl pass)
-- | Rule Declaration
data RuleDecl pass
- = HsRule -- Source rule
- (XHsRule pass) -- After renamer, free-vars from the LHS and RHS
- (Located (SourceText,RuleName)) -- Rule name
- -- Note [Pragma source text] in BasicTypes
- Activation
- [LRuleBndr pass] -- Forall'd vars; after typechecking this
- -- includes tyvars
- (Located (HsExpr pass)) -- LHS
- (Located (HsExpr pass)) -- RHS
- -- ^
- -- - 'ApiAnnotation.AnnKeywordId' :
- -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
- -- 'ApiAnnotation.AnnVal',
- -- 'ApiAnnotation.AnnClose',
- -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
- -- 'ApiAnnotation.AnnEqual',
-
- -- For details on above see note [Api annotations] in ApiAnnotation
+ = HsRule -- Source rule
+ { rd_ext :: XHsRule pass
+ -- ^ After renamer, free-vars from the LHS and RHS
+ , rd_name :: Located (SourceText,RuleName)
+ -- ^ Note [Pragma source text] in BasicTypes
+ , rd_act :: Activation
+ , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)]
+ -- ^ Forall'd type vars
+ , rd_tmvs :: [LRuleBndr pass]
+ -- ^ Forall'd term vars, before typechecking; after typechecking
+ -- this includes all forall'd vars
+ , rd_lhs :: Located (HsExpr pass)
+ , rd_rhs :: Located (HsExpr pass)
+ }
+ -- ^
+ -- - 'ApiAnnotation.AnnKeywordId' :
+ -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
+ -- 'ApiAnnotation.AnnVal',
+ -- 'ApiAnnotation.AnnClose',
+ -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
+ -- 'ApiAnnotation.AnnEqual',
| XRuleDecl (XXRuleDecl pass)
data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
@@ -2195,21 +2206,29 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
-instance (p ~ GhcPass pass, OutputableBndrId p)
- => Outputable (RuleDecls p) where
- ppr (HsRules _ st rules)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecls p) where
+ ppr (HsRules { rds_src = st
+ , rds_rules = rules })
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
ppr (XRuleDecls x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where
- ppr (HsRule _ name act ns lhs rhs)
+ ppr (HsRule { rd_name = name
+ , rd_act = act
+ , rd_tyvs = tys
+ , rd_tmvs = tms
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
= sep [pprFullRuleName name <+> ppr act,
- nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
+ nest 4 (pp_forall_ty tys <+> pp_forall_tm tys
+ <+> pprExpr (unLoc lhs)),
nest 6 (equals <+> pprExpr (unLoc rhs)) ]
where
- pp_forall | null ns = empty
- | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
+ pp_forall_ty Nothing = empty
+ pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
+ pp_forall_tm Nothing | null tms = empty
+ pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
ppr (XRuleDecl x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index dea72c3e64..d887a24052 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -335,7 +335,7 @@ data HsExpr p
| HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
- | HsAppType (XAppTypeE p) (LHsExpr p) -- ^ Visible type application
+ | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application
--
-- Explicit type argument; e.g f @Int x y
-- NB: Has wildcards, but no implicit quantification
@@ -499,10 +499,10 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| ExprWithTySig
- (XExprWithTySig p) -- Retain the signature,
- -- as HsSigType Name, for
- -- round-tripping purposes
+ (XExprWithTySig p)
+
(LHsExpr p)
+ (LHsSigWcType (NoGhcTc p))
-- | Arithmetic sequence
--
@@ -723,9 +723,7 @@ type instance XLam (GhcPass _) = NoExt
type instance XLamCase (GhcPass _) = NoExt
type instance XApp (GhcPass _) = NoExt
-type instance XAppTypeE GhcPs = LHsWcType GhcPs
-type instance XAppTypeE GhcRn = LHsWcType GhcRn
-type instance XAppTypeE GhcTc = LHsWcType GhcRn
+type instance XAppTypeE (GhcPass _) = NoExt
type instance XOpApp GhcPs = NoExt
type instance XOpApp GhcRn = Fixity
@@ -766,9 +764,7 @@ type instance XRecordUpd GhcPs = NoExt
type instance XRecordUpd GhcRn = NoExt
type instance XRecordUpd GhcTc = RecordUpdTc
-type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs)
-type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn)
-type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn)
+type instance XExprWithTySig (GhcPass _) = NoExt
type instance XArithSeq GhcPs = NoExt
type instance XArithSeq GhcRn = NoExt
@@ -1086,7 +1082,7 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
= hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
-ppr_expr (ExprWithTySig sig expr)
+ppr_expr (ExprWithTySig _ expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
@@ -1163,11 +1159,11 @@ ppr_expr (XExpr x) = ppr x
ppr_apps :: (OutputableBndrId (GhcPass p))
=> HsExpr (GhcPass p)
- -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))]
+ -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
-> SDoc
ppr_apps (HsApp _ (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
-ppr_apps (HsAppType arg (L _ fun)) args
+ppr_apps (HsAppType _ (L _ fun) arg) args
= ppr_apps fun (Right arg : args)
ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
where
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index a7c467dce4..43653a52bd 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -27,6 +27,8 @@ import Var
import Outputable
import SrcLoc (Located)
+import Data.Kind
+
{-
Note [Trees that grow]
~~~~~~~~~~~~~~~~~~~~~~
@@ -85,6 +87,18 @@ type instance IdP GhcTc = Id
type LIdP p = Located (IdP p)
+-- | Marks that a field uses the GhcRn variant even when the pass
+-- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because
+-- HsType GhcTc should never occur.
+type family NoGhcTc (p :: Type) where
+ -- this way, GHC can figure out that the result is a GhcPass
+ NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)
+ NoGhcTc other = other
+
+type family NoGhcTcPass (p :: Pass) :: Pass where
+ NoGhcTcPass 'Typechecked = 'Renamed
+ NoGhcTcPass other = other
+
-- =====================================================================
-- Type families for the HsBinds extension points
@@ -423,12 +437,12 @@ type ForallXRuleDecls (c :: * -> Constraint) (x :: *) =
-- -------------------------------------
-- RuleDecl type families
-type family XHsRule x
-type family XXRuleDecl x
+type family XHsRule x
+type family XXRuleDecl x
type ForallXRuleDecl (c :: * -> Constraint) (x :: *) =
- ( c (XHsRule x)
- , c (XXRuleDecl x)
+ ( c (XHsRule x)
+ , c (XXRuleDecl x)
)
-- -------------------------------------
@@ -1079,21 +1093,9 @@ type ConvertIdX a b =
-- | Provide a summary constraint that gives all am Outputable constraint to
-- extension points needing one
type OutputableX p = -- See Note [OutputableX]
- (
- Outputable (XSigPat p)
- , Outputable (XSigPat GhcRn)
-
- , Outputable (XIPBinds p)
-
- , Outputable (XExprWithTySig p)
- , Outputable (XExprWithTySig GhcRn)
-
- , Outputable (XAppTypeE p)
- , Outputable (XAppTypeE GhcRn)
-
+ ( Outputable (XIPBinds p)
, Outputable (XViaStrategy p)
, Outputable (XViaStrategy GhcRn)
-
)
-- TODO: Should OutputableX be included in OutputableBndrId?
@@ -1104,5 +1106,9 @@ type OutputableX p = -- See Note [OutputableX]
type OutputableBndrId id =
( OutputableBndr (NameOrRdrName (IdP id))
, OutputableBndr (IdP id)
+ , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id)))
+ , OutputableBndr (IdP (NoGhcTc id))
+ , NoGhcTc id ~ NoGhcTc (NoGhcTc id)
, OutputableX id
+ , OutputableX (NoGhcTc id)
)
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index db323d9a5e..5c7a6f1b81 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -250,11 +250,11 @@ data Pat p
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SigPat (XSigPat p) -- Before typechecker
- -- Signature can bind both
- -- kind and type vars
- -- After typechecker: Type
+ | SigPat (XSigPat p) -- After typechecker: Type
(LPat p) -- Pattern with a type signature
+ (LHsSigWcType (NoGhcTc p)) -- Signature can bind both
+ -- kind and type vars
+
-- ^ Pattern with a type signature
------------ Pattern coercions (translation only) ---------------
@@ -319,8 +319,8 @@ type instance XNPlusKPat GhcPs = NoExt
type instance XNPlusKPat GhcRn = NoExt
type instance XNPlusKPat GhcTc = Type
-type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
-type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
+type instance XSigPat GhcPs = NoExt
+type instance XSigPat GhcRn = NoExt
type instance XSigPat GhcTc = Type
type instance XCoPat (GhcPass _) = NoExt
@@ -524,7 +524,7 @@ pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens
-> if parens
then pprParendPat appPrec pat
else pprPat pat
-pprPat (SigPat ty pat) = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (ListPat _ pats) = brackets (interpp'SP pats)
pprPat (TuplePat _ pats bx) = tupleParens (boxityTupleSort bx)
(pprWithCommas ppr pats)
@@ -679,7 +679,7 @@ isIrrefutableHsPat pat
go1 (ParPat _ pat) = go pat
go1 (AsPat _ _ pat) = go pat
go1 (ViewPat _ _ pat) = go pat
- go1 (SigPat _ pat) = go pat
+ go1 (SigPat _ pat _) = go pat
go1 (TuplePat _ pats _) = all go pats
go1 (SumPat {}) = False
-- See Note [Unboxed sum patterns aren't irrefutable]
@@ -793,7 +793,7 @@ collectEvVarsPat pat =
$ unionManyBags
$ map collectEvVarsLPat
$ hsConPatArgs args
- SigPat _ p -> collectEvVarsLPat p
+ SigPat _ p _ -> collectEvVarsLPat p
CoPat _ _ p _ -> collectEvVarsPat p
ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
_other_pat -> emptyBag
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index c36a54f66d..8200707e16 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -63,7 +63,7 @@ module HsTypes (
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
-- Printing
- pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
+ pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
) where
@@ -1298,6 +1298,8 @@ instance Outputable HsWildCardInfo where
pprAnonWildCard :: SDoc
pprAnonWildCard = char '_'
+-- | Prints a forall; When passed an empty list, prints @forall.@ only when
+-- @-dppr-debug@
pprHsForAll :: (OutputableBndrId (GhcPass p))
=> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
@@ -1313,15 +1315,17 @@ pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
=> Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
- = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
+ = pp_forall <+> pprHsContextExtra (isJust extra) (unLoc cxt)
where
- show_extra = isJust extra
+ pp_forall | null qtvs = whenPprDebug (forAllLit <> dot)
+ | otherwise = forAllLit <+> interppSP qtvs <> dot
-pprHsForAllTvs :: (OutputableBndrId (GhcPass p))
- => [LHsTyVarBndr (GhcPass p)] -> SDoc
-pprHsForAllTvs qtvs
- | null qtvs = whenPprDebug (forAllLit <+> dot)
- | otherwise = forAllLit <+> interppSP qtvs <> dot
+-- | Version of 'pprHsForall' or 'pprHsForallExtra' that will always print
+-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'
+pprHsExplicitForAll :: (OutputableBndrId (GhcPass p))
+ => Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc
+pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
+pprHsExplicitForAll Nothing = empty
pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
@@ -1390,7 +1394,7 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
- = sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
+ = sep [pprHsForAll tvs (noLoc []), ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 431f3f0138..e5e4ba66e6 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -176,9 +176,9 @@ mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
-mkHsAppType :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
+mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)
=> LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
-mkHsAppType e t = addCLoc e t_body (HsAppType paren_wct e)
+mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct)
where
t_body = hswc_body t
paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
@@ -1074,7 +1074,7 @@ collect_lpat (L _ pat) bndrs
go (NPat {}) = bndrs
go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
- go (SigPat _ pat) = collect_lpat pat bndrs
+ go (SigPat _ pat _) = collect_lpat pat bndrs
go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go pat
@@ -1356,7 +1356,7 @@ lPatImplicits = hs_lpat
hs_pat (ListPat _ pats) = hs_lpats pats
hs_pat (TuplePat _ pats _) = hs_lpats pats
- hs_pat (SigPat _ pat) = hs_lpat pat
+ hs_pat (SigPat _ pat _) = hs_lpat pat
hs_pat (CoPat _ _ pat _) = hs_pat pat
hs_pat (ConPatIn _ ps) = details ps
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index a8a33bfaad..77bcd76915 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -909,7 +909,7 @@ hscCheckSafeImports tcg_env = do
-> return tcg_env'
warns dflags rules = listToBag $ map (warnRules dflags) rules
- warnRules dflags (L loc (HsRule _ n _ _ _ _)) =
+ warnRules dflags (L loc (HsRule { rd_name = n })) =
mkPlainWarnMsg dflags loc $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index ce59ca1877..0bd83ce246 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -4,7 +4,7 @@
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module HscStats ( ppSourceStats ) where
@@ -181,4 +181,3 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
sum7 = foldr add7 (0,0,0,0,0,0,0)
add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
-
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 9f43e36984..8a10516819 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1,3 +1,4 @@
+
-- -*-haskell-*-
-- ---------------------------------------------------------------------------
-- (c) The University of Glasgow 1997-2003
@@ -81,13 +82,13 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
-- compiler/utils
-import Util ( looksLikePackageName )
+import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
import GhcPrelude
import qualified GHC.LanguageExtensions as LangExt
}
-%expect 235 -- shift/reduce conflicts
+%expect 236 -- shift/reduce conflicts
{- Last updated: 04 June 2018
@@ -120,16 +121,7 @@ follows. Shift parses as if the 'module' keyword follows.
-------------------------------------------------------------------------------
-state 57 contains 2 shift/reduce conflicts.
-
- *** strict_mark -> unpackedness .
- strict_mark -> unpackedness . strictness
-
- Conflicts: '~' '!'
-
--------------------------------------------------------------------------------
-
-state 61 contains 1 shift/reduce conflict.
+state 60 contains 1 shift/reduce conflict.
context -> btype .
*** type -> btype .
@@ -139,7 +131,7 @@ state 61 contains 1 shift/reduce conflict.
-------------------------------------------------------------------------------
-state 62 contains 46 shift/reduce conflicts.
+state 61 contains 46 shift/reduce conflicts.
*** btype -> tyapps .
tyapps -> tyapps . tyapp
@@ -157,7 +149,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 144 contains 15 shift/reduce conflicts.
+state 143 contains 15 shift/reduce conflicts.
exp -> infixexp . '::' sigtype
exp -> infixexp . '-<' exp
@@ -182,7 +174,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 149 contains 67 shift/reduce conflicts.
+state 148 contains 67 shift/reduce conflicts.
*** exp10 -> fexp .
fexp -> fexp . aexp
@@ -200,7 +192,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 204 contains 27 shift/reduce conflicts.
+state 203 contains 27 shift/reduce conflicts.
aexp2 -> TH_TY_QUOTE . tyvar
aexp2 -> TH_TY_QUOTE . gtycon
@@ -219,7 +211,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 300 contains 1 shift/reduce conflicts.
+state 299 contains 1 shift/reduce conflicts.
rule -> STRING . rule_activation rule_forall infixexp '=' exp
@@ -237,7 +229,7 @@ a rule instructing how to rewrite the expression '[0] f'.
-------------------------------------------------------------------------------
-state 310 contains 1 shift/reduce conflict.
+state 309 contains 1 shift/reduce conflict.
*** type -> btype .
type -> btype . '->' ctype
@@ -248,7 +240,7 @@ Same as state 61 but without contexts.
-------------------------------------------------------------------------------
-state 354 contains 1 shift/reduce conflicts.
+state 353 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(' commas . ')'
@@ -263,7 +255,7 @@ if -XTupleSections is not specified.
-------------------------------------------------------------------------------
-state 409 contains 1 shift/reduce conflicts.
+state 408 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(#' commas . '#)'
@@ -275,7 +267,7 @@ Same as State 354 for unboxed tuples.
-------------------------------------------------------------------------------
-state 417 contains 67 shift/reduce conflicts.
+state 416 contains 67 shift/reduce conflicts.
*** exp10 -> '-' fexp .
fexp -> fexp . aexp
@@ -299,7 +291,7 @@ parenthesized infix type expression of length 1.
-------------------------------------------------------------------------------
-state 675 contains 1 shift/reduce conflicts.
+state 678 contains 1 shift/reduce conflicts.
*** aexp2 -> ipvar .
dbind -> ipvar . '=' exp
@@ -314,7 +306,7 @@ sensible meaning, namely the lhs of an implicit binding.
-------------------------------------------------------------------------------
-state 752 contains 1 shift/reduce conflicts.
+state 756 contains 1 shift/reduce conflicts.
rule -> STRING rule_activation . rule_forall infixexp '=' exp
@@ -331,7 +323,7 @@ doesn't include 'forall'.
-------------------------------------------------------------------------------
-state 986 contains 1 shift/reduce conflicts.
+state 992 contains 1 shift/reduce conflicts.
transformqual -> 'then' 'group' . 'using' exp
transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -341,7 +333,29 @@ state 986 contains 1 shift/reduce conflicts.
-------------------------------------------------------------------------------
-state 1367 contains 1 shift/reduce conflict.
+state 1089 contains 1 shift/reduce conflicts.
+
+ rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'
+ *** rule_foralls -> 'forall' rule_vars '.' .
+
+ Conflict: 'forall'
+
+Example ambigutiy: '{-# RULES "name" forall a. forall ... #-}'
+
+Here the parser cannot tell whether the second 'forall' is the beginning of
+a term-level quantifier, for example:
+
+'{-# RULES "name" forall a. forall x. id @a x = x #-}'
+
+or a valid variable named 'forall', for example a function @:: Int -> Int@
+
+'{-# RULES "name" forall a. forall 0 = 0 #-}'
+
+Shift means the parser only allows the former. Also see conflict 753 above.
+
+-------------------------------------------------------------------------------
+
+state 1390 contains 1 shift/reduce conflict.
*** atype -> tyvar .
tv_bndr -> '(' tyvar . '::' kind ')'
@@ -1125,7 +1139,7 @@ inst_decl :: { LInstDecl GhcPs }
(mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
-- data/newtype instance declaration
- | data_or_newtype 'instance' capi_ctype tycl_hdr constrs
+ | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
Nothing (reverse (snd $ unLoc $5))
@@ -1133,7 +1147,7 @@ inst_decl :: { LInstDecl GhcPs }
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
-- GADT instance declaration
- | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
+ | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
@@ -1223,11 +1237,16 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
- : type '=' ktype
- -- Note the use of type for the head; this allows
- -- infix type constructors and type patterns
- {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
+ : 'forall' tv_bndrs '.' type '=' ktype
+ {% do { hintExplicitForall (getLoc $1)
+ ; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6
+ ; ams (sLL $4 $> (mj AnnEqual $5:ann, eqn))
+ [mu AnnForall $1, mj AnnDot $3] } }
+ | type '=' ktype
+ {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
+ -- Note the use of type for the head; this allows
+ -- infix type constructors and type patterns
-- Associated type family declarations
--
@@ -1291,13 +1310,13 @@ at_decl_inst :: { LInstDecl GhcPs }
-- data/newtype instance declaration, with optional 'instance' keyword
-- (can't use opt_instance because you get reduce/reduce errors)
- | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
+ | data_or_newtype capi_ctype tycl_hdr_inst constrs maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
Nothing (reverse (snd $ unLoc $4))
(fmap reverse $5))
((fst $ unLoc $1):(fst $ unLoc $4)) }
- | data_or_newtype 'instance' capi_ctype tycl_hdr constrs maybe_derivings
+ | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6))
@@ -1305,7 +1324,7 @@ at_decl_inst :: { LInstDecl GhcPs }
-- GADT instance declaration, with optional 'instance' keyword
-- (can't use opt_instance because you get reduce/reduce errors)
- | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
+ | data_or_newtype capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
@@ -1313,7 +1332,7 @@ at_decl_inst :: { LInstDecl GhcPs }
(fmap reverse $6))
((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
- | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
+ | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
@@ -1362,6 +1381,22 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
}
| type { sL1 $1 (Nothing, $1) }
+tycl_hdr_inst :: { Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) }
+ : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall (getLoc $1)
+ >> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
+ >> ams (sLL $1 $> $ (Just $4, Just $2, $6))
+ [mu AnnForall $1, mj AnnDot $3])
+ }
+ | 'forall' tv_bndrs '.' type {% hintExplicitForall (getLoc $1)
+ >> ams (sLL $1 $> $ (Nothing, Just $2, $4))
+ [mu AnnForall $1, mj AnnDot $3]
+ }
+ | context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
+ >> (return (sLL $1 $> (Just $1, Nothing, $3)))
+ }
+ | type { sL1 $1 (Nothing, Nothing, $1) }
+
+
capi_ctype :: { Maybe (Located CType) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
{% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
@@ -1607,11 +1642,13 @@ rules :: { OrdList (LRuleDecl GhcPs) }
| {- empty -} { nilOL }
rule :: { LRuleDecl GhcPs }
- : STRING rule_activation rule_forall infixexp '=' exp
- {%ams (sLL $1 $> $ (HsRule noExt (L (gl $1) (getSTRINGs $1,getSTRING $1))
- ((snd $2) `orElse` AlwaysActive)
- (snd $3) $4 $6))
- (mj AnnEqual $5 : (fst $2) ++ (fst $3)) }
+ : STRING rule_activation rule_foralls infixexp '=' exp
+ {%ams (sLL $1 $> $ HsRule { rd_ext = noExt
+ , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
+ , rd_act = (snd $2) `orElse` AlwaysActive
+ , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
+ , rd_lhs = $4, rd_rhs = $6 })
+ (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
rule_activation :: { ([AddAnn],Maybe Activation) }
@@ -1627,20 +1664,48 @@ rule_explicit_activation :: { ([AddAnn]
| '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3]
,NeverActive) }
-rule_forall :: { ([AddAnn],[LRuleBndr GhcPs]) }
- : 'forall' rule_var_list '.' { ([mu AnnForall $1,mj AnnDot $3],$2) }
- | {- empty -} { ([],[]) }
-
-rule_var_list :: { [LRuleBndr GhcPs] }
- : rule_var { [$1] }
- | rule_var rule_var_list { $1 : $2 }
-
-rule_var :: { LRuleBndr GhcPs }
- : varid { sLL $1 $> (RuleBndr noExt $1) }
- | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig noExt $2
- (mkLHsSigWcType $4)))
+rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs]) }
+ : 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2
+ in hintExplicitForall (getLoc $1)
+ >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
+ >> return ([mu AnnForall $1,mj AnnDot $3,
+ mu AnnForall $4,mj AnnDot $6],
+ Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }
+ | 'forall' rule_vars '.' { ([mu AnnForall $1,mj AnnDot $3],
+ Nothing, mkRuleBndrs $2) }
+ | {- empty -} { ([], Nothing, []) }
+
+rule_vars :: { [LRuleTyTmVar] }
+ : rule_var rule_vars { $1 : $2 }
+ | {- empty -} { [] }
+
+rule_var :: { LRuleTyTmVar }
+ : varid { sLL $1 $> (RuleTyTmVar $1 Nothing) }
+ | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleTyTmVar $2 (Just $4)))
[mop $1,mu AnnDcolon $3,mcp $5] }
+{- Note [Parsing explicit foralls in Rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We really want the above definition of rule_foralls to be:
+
+ rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'
+ | 'forall' rule_vars '.'
+ | {- empty -}
+
+where rule_vars (term variables) can be named "forall", "family", or "role",
+but tv_vars (type variables) cannot be. However, such a definition results
+in a reduce/reduce conflict. For example, when parsing:
+> {-# RULE "name" forall a ... #-}
+before the '...' it is impossible to determine whether we should be in the
+first or second case of the above.
+
+This is resolved by using rule_vars (which is more general) for both, and
+ensuring that type-level quantified variables do not have the names "forall",
+"family", or "role" in the function 'checkRuleTyVarBndrNames' in RdrHsSyn.hs
+Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative
+to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
+-}
+
-----------------------------------------------------------------------------
-- Warnings and deprecations (c.f. rules)
@@ -2463,7 +2528,7 @@ quasiquote :: { Located (HsSplice GhcPs) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { LHsExpr GhcPs }
- : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1)
+ : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig noExt $1 (mkLHsSigWcType $3))
[mu AnnDcolon $2] }
| infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
HsFirstOrderApp True)
@@ -2561,7 +2626,7 @@ fexp :: { LHsExpr GhcPs }
: fexp aexp {% checkBlockArguments $1 >> checkBlockArguments $2 >>
return (sLL $1 $> $ (HsApp noExt $1 $2)) }
| fexp TYPEAPP atype {% checkBlockArguments $1 >>
- ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1)
+ ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
[mj AnnAt $2] }
| 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2)
[mj AnnStatic $1] }
@@ -3308,6 +3373,8 @@ tyvarid :: { Located RdrName }
| 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }
| 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") }
| 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }
+ -- If this changes relative to varid, update 'checkRuleTyVarBndrNames' in RdrHsSyn.hs
+ -- See Note [Parsing explicit foralls in Rules]
-----------------------------------------------------------------------------
-- Variables
@@ -3348,6 +3415,8 @@ varid :: { Located RdrName }
| 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") }
| 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") }
| 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") }
+ -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames' in RdrHsSyn.hs
+ -- See Note [Parsing explicit foralls in Rules]
qvarsym :: { Located RdrName }
: varsym { $1 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 1e89d5a459..9917d960f8 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -54,6 +54,9 @@ module RdrHsSyn (
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
checkDoAndIfThenElse,
+ LRuleTyTmVar, RuleTyTmVar(..),
+ mkRuleBndrs, mkRuleTyVarBndrs,
+ checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
parseErrorSDoc, hintBangPat,
@@ -174,11 +177,13 @@ mkATDefault :: LTyFamInstDecl GhcPs
-- some necessary paren annotations to the parsing context. Naturally, this
-- is not something that the "Convert" use cares about.
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
- | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
- , feqn_rhs = rhs } <- e
+ | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
+ , feqn_fixity = fixity, feqn_rhs = rhs } <- e
= do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
; let f = L loc (FamEqn { feqn_ext = noExt
, feqn_tycon = tc
+ , feqn_bndrs = ASSERT( isNothing bndrs )
+ Nothing
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs })
@@ -235,14 +240,16 @@ mkTySynonym loc lhs rhs
, tcdFixity = fixity
, tcdRhs = rhs })) }
-mkTyFamInstEqn :: LHsType GhcPs
+mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
+ -> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
-mkTyFamInstEqn lhs rhs
+mkTyFamInstEqn bndrs lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; return (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExt
, feqn_tycon = tc
+ , feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = rhs }),
@@ -251,18 +258,19 @@ mkTyFamInstEqn lhs rhs
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
- -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
+ -> Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
-mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkDataFamInst loc new_or_data cType (L _ (mcxt, bndrs, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExt
, feqn_tycon = tc
+ , feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = defn }))))) }
@@ -844,6 +852,33 @@ checkDatatypeContext (Just (L loc c))
(text "Illegal datatype context (use DatatypeContexts):" <+>
pprHsContext c)
+type LRuleTyTmVar = Located RuleTyTmVar
+data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
+-- ^ Essentially a wrapper for a @RuleBndr GhcPs@
+
+-- turns RuleTyTmVars into RuleBnrs - this is straightforward
+mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
+mkRuleBndrs = fmap (fmap cvt_one)
+ where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExt v
+ cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExt v (mkLHsSigWcType sig)
+
+-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
+mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
+mkRuleTyVarBndrs = fmap (fmap cvt_one)
+ where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExt (fmap tm_to_ty v)
+ cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExt (fmap tm_to_ty v) sig
+ -- takes something in namespace 'varName' to something in namespace 'tvName'
+ tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
+ tm_to_ty _ = panic "mkRuleTyVarBndrs"
+
+-- See note [Parsing explicit foralls in Rules] in Parser.y
+checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
+checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
+ where check (L loc (Unqual occ)) = do
+ when ((occNameString occ ==) `any` ["forall","family","role"])
+ (parseErrorSDoc loc (text $ "parse error on input " ++ occNameString occ))
+ check _ = panic "checkRuleTyVarBndrNames"
+
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(L loc r)
= do allowed <- extension traditionalRecordSyntaxEnabled
@@ -1038,8 +1073,8 @@ checkAPat msg loc e0 = do
-- view pattern is well-formed if the pattern is
EViewPat _ expr patE -> checkLPat msg patE >>=
(return . (\p -> ViewPat noExt expr p))
- ExprWithTySig t e -> do e <- checkLPat msg e
- return (SigPat t e)
+ ExprWithTySig _ e t -> do e <- checkLPat msg e
+ return (SigPat noExt e t)
-- n+k patterns
OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
@@ -1114,7 +1149,7 @@ checkValDef :: SDoc
checkValDef msg _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= checkPatBind msg (L (combineLocs lhs sig)
- (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
+ (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 7cd5c55245..60dead089b 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -958,7 +958,7 @@ renameSig _ (IdSig _ x)
renameSig ctxt sig@(TypeSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; let doc = TypeSigCtx (ppr_sig_bndrs vs)
- ; (new_ty, fvs) <- rnHsSigWcType doc ty
+ ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty
; return (TypeSig noExt new_vs new_ty, fvs) }
renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index ae2bdf7a2b..46ac6b8724 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -167,10 +167,10 @@ rnExpr (HsApp x fun arg)
; (arg',fvArg) <- rnLExpr arg
; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
-rnExpr (HsAppType arg fun)
+rnExpr (HsAppType x fun arg)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
- ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) }
+ ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }
rnExpr (OpApp _ e1 op e2)
= do { (e1', fv_e1) <- rnLExpr e1
@@ -310,11 +310,11 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
, rupd_flds = rbinds' }
, fvExpr `plusFV` fvRbinds) }
-rnExpr (ExprWithTySig pty expr)
- = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
+rnExpr (ExprWithTySig _ expr pty)
+ = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
- ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) }
+ ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }
rnExpr (HsIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
@@ -1820,7 +1820,7 @@ isStrictPattern (L _ pat) =
AsPat _ _ p -> isStrictPattern p
ParPat _ p -> isStrictPattern p
ViewPat _ _ p -> isStrictPattern p
- SigPat _ p -> isStrictPattern p
+ SigPat _ p _ -> isStrictPattern p
BangPat{} -> True
ListPat{} -> True
TuplePat{} -> True
@@ -1944,7 +1944,7 @@ isReturnApp monad_names (L _ e) = case e of
_otherwise -> Nothing
where
is_var f (L _ (HsPar _ e)) = is_var f e
- is_var f (L _ (HsAppType _ e)) = is_var f e
+ is_var f (L _ (HsAppType _ e _)) = is_var f e
is_var f (L _ (HsVar _ (L _ r))) = f r
-- TODO: I don't know how to get this right for rebindable syntax
is_var _ _ = False
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 6195309cab..a80a6982eb 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -213,7 +213,7 @@ matchNameMaker ctxt = LamMk report_unused
_ -> True
rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
-rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig)
+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
newPatLName name_maker rdr_name@(L loc _)
@@ -393,7 +393,7 @@ rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM
-- we need to bind pattern variables for view pattern expressions
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
-rnPatAndThen mk (SigPat sig pat )
+rnPatAndThen mk (SigPat x pat sig)
-- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
-- important to rename its type signature _before_ renaming the rest of the
-- pattern, so that type variables are first bound by the _outermost_ pattern
@@ -405,7 +405,7 @@ rnPatAndThen mk (SigPat sig pat )
-- ~~~~~~~~~~~~~~~^ the same `a' then used here
= do { sig' <- rnHsSigCps sig
; pat' <- rnLPatAndThen mk pat
- ; return (SigPat sig' pat' ) }
+ ; return (SigPat x pat' sig' ) }
rnPatAndThen mk (LitPat x lit)
| HsString src s <- lit
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 9687e72a10..48739cdf69 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -50,7 +50,7 @@ import NameEnv
import Avail
import Outputable
import Bag
-import BasicTypes ( RuleName, pprRuleName )
+import BasicTypes ( pprRuleName )
import FastString
import SrcLoc
import DynFlags
@@ -67,6 +67,7 @@ import Control.Arrow ( first )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.Maybe ( isNothing, maybe, fromMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
{- | @rnSourceDecl@ "renames" declarations.
@@ -693,33 +694,41 @@ rnFamInstEqn :: HsDocContext
-> RnM (FamInstEqn GhcRn rhs', FreeVars)
rnFamInstEqn doc mb_cls rhs_kvars
(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+ , feqn_bndrs = mb_bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = payload }}) rn_payload
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
- ; let loc = case pats of
- [] -> pprPanic "rnFamInstEqn" (ppr tycon)
- (L loc _ : []) -> loc
- (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
-
- pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
- pat_vars = freeKiTyVarsAllVars $
- rmDupsInRdrTyVars pat_kity_vars_with_dups
+ ; let pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
-- Use the "...Dups" form because it's needed
-- below to report unsed binder on the LHS
- ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars
-
+ ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups
+
+ -- all pat vars not explicitly bound (see extractHsTvBndrs)
+ ; let mb_imp_kity_vars = extractHsTvBndrs <$> mb_bndrs <*> pure pat_kity_vars
+ imp_vars = case mb_imp_kity_vars of
+ -- kind vars are the only ones free if we have an explicit forall
+ Just nbnd_kity_vars -> freeKiTyVarsKindVars nbnd_kity_vars
+ -- all pattern vars are free otherwise
+ Nothing -> freeKiTyVarsAllVars pat_kity_vars
+ ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars
+
+ ; let bndrs = fromMaybe [] mb_bndrs
+ bnd_vars = map hsLTyVarLocName bndrs
+ payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars
-- Make sure to filter out the kind variables that were explicitly
-- bound in the type patterns.
- ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars
- ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars
+ ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
- ; let all_var_names = pat_var_names ++ payload_var_names
+ -- all names not bound in an explict forall
+ ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
-- All the free vars of the family patterns
-- with a sensible binding location
- ; ((pats', payload'), fvs)
- <- bindLocalNamesFV all_var_names $
+ ; ((bndrs', pats', payload'), fvs)
+ <- bindLocalNamesFV all_imp_var_names $
+ bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
+ mb_cls bndrs $ \bndrs' ->
do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
; (payload', rhs_fvs) <- rn_payload doc payload
@@ -728,7 +737,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
; let groups :: [NonEmpty (Located RdrName)]
groups = equivClasses cmpLocated $
freeKiTyVarsAllVars pat_kity_vars_with_dups
- ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
+ ; nms_dups <- mapM (lookupOccRn . unLoc) $
[ tv | (tv :| (_:_)) <- groups ]
-- Add to the used variables
-- a) any variables that appear *more than once* on the LHS
@@ -736,27 +745,27 @@ rnFamInstEqn doc mb_cls rhs_kvars
-- b) for associated instances, the variables
-- of the instance decl. See
-- Note [Unused type variables in family instances]
- ; let tv_nms_used = extendNameSetList rhs_fvs $
- inst_tvs ++ tv_nms_dups
+ ; let nms_used = extendNameSetList rhs_fvs $
+ inst_tvs ++ nms_dups
inst_tvs = case mb_cls of
Nothing -> []
Just (_, inst_tvs) -> inst_tvs
- ; warnUnusedTypePatterns pat_var_names tv_nms_used
+ all_nms = all_imp_var_names
+ ++ map hsLTyVarName bndrs'
+ ; warnUnusedTypePatterns all_nms nms_used
-- See Note [Renaming associated types]
- ; let bad_tvs = case mb_cls of
- Nothing -> []
- Just (_,cls_tkvs) -> filter is_bad cls_tkvs
- var_name_set = mkNameSet all_var_names
-
+ ; let bad_tvs = maybe [] (filter is_bad . snd) mb_cls
+ var_name_set = mkNameSet (map hsLTyVarName bndrs'
+ ++ all_imp_var_names)
is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
- && not (cls_tkv `elemNameSet` var_name_set)
+ && not (cls_tkv `elemNameSet` var_name_set)
; unless (null bad_tvs) (badAssocRhs bad_tvs)
- ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
+ ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
; let anon_wcs = concatMap collectAnonWildCards pats'
- all_ibs = anon_wcs ++ all_var_names
+ all_ibs = anon_wcs ++ all_imp_var_names
-- all_ibs: include anonymous wildcards in the implicit
-- binders In a type pattern they behave just like any
-- other type variable except for being anoymous. See
@@ -768,6 +777,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
, hsib_body
= FamEqn { feqn_ext = noExt
, feqn_tycon = tycon'
+ , feqn_bndrs = bndrs' <$ mb_bndrs
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = payload' } },
@@ -796,6 +806,7 @@ rnTyFamDefltEqn :: Name
-> TyFamDefltEqn GhcPs
-> RnM (TyFamDefltEqn GhcRn, FreeVars)
rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
+ , feqn_bndrs = bndrs
, feqn_pats = tyvars
, feqn_fixity = fixity
, feqn_rhs = rhs })
@@ -805,6 +816,8 @@ rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
; (rhs', fvs) <- rnLHsType ctx rhs
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tycon'
+ , feqn_bndrs = ASSERT( isNothing bndrs )
+ Nothing
, feqn_pats = tyvars'
, feqn_fixity = fixity
, feqn_rhs = rhs' }, fvs) } }
@@ -959,7 +972,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
; (mds', ty', fvs)
<- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
- rnHsSigWcType DerivDeclCtx ty
+ rnHsSigWcType BindUnlessForall DerivDeclCtx ty
; return (DerivDecl noExt ty' mds' overlap, fvs) }
where
loc = getLoc $ hsib_body $ hswc_body ty
@@ -979,51 +992,75 @@ standaloneDerivErr
-}
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules _ src rules)
+rnHsRuleDecls (HsRules { rds_src = src
+ , rds_rules = rules })
= do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
- ; return (HsRules noExt src rn_rules,fvs) }
+ ; return (HsRules { rds_ext = noExt
+ , rds_src = src
+ , rds_rules = rn_rules }, fvs) }
rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs)
- = do { let rdr_names_w_loc = map get_var vars
+rnHsRuleDecl (HsRule { rd_name = rule_name
+ , rd_act = act
+ , rd_tyvs = tyvs
+ , rd_tmvs = tmvs
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
+ = do { let rdr_names_w_loc = map get_var tmvs
; checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
; names <- newLocalBndrsRn rdr_names_w_loc
- ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
+ ; let doc = RuleCtx (snd $ unLoc rule_name)
+ ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->
+ bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
do { (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
- ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars'
- lhs' rhs',
- fv_lhs' `plusFV` fv_rhs') } }
+ ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs'
+ , rd_name = rule_name
+ , rd_act = act
+ , rd_tyvs = tyvs'
+ , rd_tmvs = tmvs'
+ , rd_lhs = lhs'
+ , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
where
get_var (L _ (RuleBndrSig _ v _)) = v
get_var (L _ (RuleBndr _ v)) = v
get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl"
+ in_rule = text "in the rule" <+> pprFullRuleName rule_name
rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
-bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
+bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
+ -> [LRuleBndr GhcPs] -> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-bindHsRuleVars rule_name vars names thing_inside
+bindRuleTmVars doc tyvs vars names thing_inside
= go vars names $ \ vars' ->
bindLocalNamesFV names (thing_inside vars')
where
- doc = RuleCtx rule_name
-
go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside
= go vars ns $ \ vars' ->
thing_inside (L l (RuleBndr noExt (L loc n)) : vars')
go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside
- = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
+ = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->
go vars ns $ \ vars' ->
thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars')
go [] [] thing_inside = thing_inside []
go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
+ bind_free_tvs = case tyvs of Nothing -> AlwaysBind
+ Just _ -> NeverBind
+
+bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]
+ -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
+ -> RnM (b, FreeVars)
+bindRuleTyVars doc in_doc (Just bndrs) thing_inside
+ = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)
+bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing
+
{-
Note [Rule LHS validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1062,7 +1099,7 @@ validRuleLhs foralls lhs
check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1
`mplus` checkl_e e2
check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2
- check (HsAppType _ e) = checkl e
+ check (HsAppType _ e _) = checkl e
check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing
check other = Just other -- Failure
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 33f9329789..abdaaae7e2 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -12,7 +12,7 @@ module RnTypes (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind,
rnHsSigType, rnHsWcType,
- rnHsSigWcType, rnHsSigWcTypeScoped,
+ HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
rnLHsInstType,
newTyVarNameRn, collectAnonWildCards,
rnConDeclFields,
@@ -83,13 +83,29 @@ to break several loop.
*********************************************************
-}
-rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
- -> RnM (LHsSigWcType GhcRn, FreeVars)
-rnHsSigWcType doc sig_ty
- = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
+data HsSigWcTypeScoping = AlwaysBind
+ -- ^ Always bind any free tyvars of the given type,
+ -- regardless of whether we have a forall at the top
+ | BindUnlessForall
+ -- ^ Unless there's forall at the top, do the same
+ -- thing as 'AlwaysBind'
+ | NeverBind
+ -- ^ Never bind any free tyvars
+
+rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+ -> RnM (LHsSigWcType GhcRn, FreeVars)
+rnHsSigWcType scoping doc sig_ty
+ = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
return (sig_ty', emptyFVs)
-rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
+rnHsSigWcTypeScoped :: HsSigWcTypeScoping
+ -- AlwaysBind: for pattern type sigs and rules we /do/ want
+ -- to bring those type variables into scope, even
+ -- if there's a forall at the top which usually
+ -- stops that happening
+ -- e.g \ (x :: forall a. a-> b) -> e
+ -- Here we do bring 'b' into scope
+ -> HsDocContext -> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-- Used for
@@ -97,33 +113,26 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
-- - Pattern type signatures
-- Wildcards are allowed
-- type signatures on binders only allowed with ScopedTypeVariables
-rnHsSigWcTypeScoped ctx sig_ty thing_inside
+rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
- ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
+ ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
}
- -- True: for pattern type sigs and rules we /do/ want
- -- to bring those type variables into scope, even
- -- if there's a forall at the top which usually
- -- stops that happening
- -- e.g \ (x :: forall a. a-> b) -> e
- -- Here we do bring 'b' into scope
-
-rn_hs_sig_wc_type :: Bool -- True <=> always bind any free tyvars of the
- -- type, regardless of whether it has
- -- a forall at the top
- -> HsDocContext
- -> LHsSigWcType GhcPs
+
+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type always_bind_free_tvs ctxt
+rn_hs_sig_wc_type scoping ctxt
(HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
thing_inside
= do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
- bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
+ bind_free_tvs = case scoping of
+ AlwaysBind -> True
+ BindUnlessForall -> not (isLHsForAllTy hs_ty)
+ NeverBind -> False
; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 0451e288be..2f27720ee5 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -244,11 +244,14 @@ warnUnused1 flag fld_env name
= when (reportable name occ) $
addUnusedWarning flag
occ (nameSrcSpan name)
- (text "Defined but not used")
+ (text $ "Defined but not used" ++ opt_str)
where
occ = case lookupNameEnv fld_env name of
Just (fl, _) -> mkVarOccFS fl
Nothing -> nameOccName name
+ opt_str = case flag of
+ Opt_WarnUnusedTypePatterns -> " on the right hand side"
+ _ -> ""
warnUnusedGRE :: GlobalRdrElt -> RnM ()
warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
index 60872f749e..4d246efc23 100644
--- a/compiler/typecheck/TcAnnotations.hs
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -7,6 +7,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
module TcAnnotations ( tcAnnotations, annCtxt ) where
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 8f4e1076ca..946cb5c136 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -5,6 +5,7 @@
-- orphan
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
+{-# LANGUAGE TypeFamilies #-}
module TcEnv(
TyThing(..), TcTyThing(..), TcId,
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 17678a5cd1..f27922f023 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -240,9 +240,9 @@ tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty
lbl = mkStrLitTy l
applyFromLabel loc fromLabel =
- HsAppType
- (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
+ HsAppType noExt
(L loc (HsVar noExt (L loc fromLabel)))
+ (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
tcExpr (HsLam x match) res_ty
= do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
@@ -266,12 +266,12 @@ tcExpr e@(HsLamCase x matches) res_ty
, text "requires"]
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
-tcExpr e@(ExprWithTySig sig_ty expr) res_ty
+tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty
= do { let loc = getLoc (hsSigWcType sig_ty)
; sig_info <- checkNoErrs $ -- Avoid error cascade
tcUserTypeSig loc sig_ty Nothing
; (expr', poly_ty) <- tcExprSig expr sig_info
- ; let expr'' = ExprWithTySig sig_ty expr'
+ ; let expr'' = ExprWithTySig noExt expr' sig_ty
; tcWrapResult e expr'' poly_ty res_ty }
{-
@@ -1112,7 +1112,7 @@ The SrcSpan is the span of the original HsPar
-}
-wrapHsArgs :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
+wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
=> LHsExpr (GhcPass id)
-> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
-> LHsExpr (GhcPass id)
@@ -1164,7 +1164,7 @@ tcApp m_herald (L sp (HsPar _ fun)) args res_ty
tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty
= tcApp m_herald fun (HsValArg arg1 : args) res_ty
-tcApp m_herald (L _ (HsAppType ty1 fun)) args res_ty
+tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty
= tcApp m_herald fun (HsTypeArg ty1 : args) res_ty
tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty
@@ -2359,7 +2359,7 @@ lookupParents rdr
-- the record expression in an update must be "obvious", i.e. the
-- outermost constructor ignoring parentheses.
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
-obviousSig (ExprWithTySig ty _) = Just ty
+obviousSig (ExprWithTySig _ _ ty) = Just ty
obviousSig (HsPar _ p) = obviousSig (unLoc p)
obviousSig _ = Nothing
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 32f081b15d..b3a4d536d1 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1850,13 +1850,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
underlying_inst_tys = changeLast inst_tys rhs_ty
nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlHsAppType e s = noLoc (HsAppType hs_ty e)
+nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)
where
hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlExprWithTySig e s = noLoc $ ExprWithTySig hs_ty
- $ parenthesizeHsExpr sigPrec e
+nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty
where
hs_ty = mkLHsSigWcType (typeToLHsType s)
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 3363aa2be0..a2016888c2 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -111,7 +111,7 @@ hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys
hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
= conLikeResTy con tys
-hsPatType (SigPat ty _) = ty
+hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
hsPatType (CoPat _ _ _ ty) = ty
@@ -751,9 +751,9 @@ zonkExpr env (HsApp x e1 e2)
new_e2 <- zonkLExpr env e2
return (HsApp x new_e1 new_e2)
-zonkExpr env (HsAppType t e)
+zonkExpr env (HsAppType x e t)
= do new_e <- zonkLExpr env e
- return (HsAppType t new_e)
+ return (HsAppType x new_e t)
-- NB: the type is an HsType; can't zonk that!
zonkExpr _ e@(HsRnBracketOut _ _ _)
@@ -877,9 +877,9 @@ zonkExpr env (RecordUpd { rupd_flds = rbinds
, rupd_out_tys = new_out_tys
, rupd_wrap = new_recwrap }}) }
-zonkExpr env (ExprWithTySig ty e)
+zonkExpr env (ExprWithTySig _ e ty)
= do { e' <- zonkLExpr env e
- ; return (ExprWithTySig ty e') }
+ ; return (ExprWithTySig noExt e' ty) }
zonkExpr env (ArithSeq expr wit info)
= do (env1, new_wit) <- zonkWit env wit
@@ -1389,10 +1389,10 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
-zonk_pat env (SigPat ty pat)
+zonk_pat env (SigPat ty pat hs_ty)
= do { ty' <- zonkTcTypeToTypeX env ty
; (env', pat') <- zonkPat env pat
- ; return (env', SigPat ty' pat') }
+ ; return (env', SigPat ty' pat' hs_ty) }
zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
= do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
@@ -1475,8 +1475,10 @@ zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
-zonkRule env (HsRule fvs name act (vars{-::[RuleBndr TcId]-}) lhs rhs)
- = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars
+zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
+ = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
; let env_lhs = setZonkType env_inside SkolemiseFlexi
-- See Note [Zonking the LHS of a RULE]
@@ -1484,13 +1486,15 @@ zonkRule env (HsRule fvs name act (vars{-::[RuleBndr TcId]-}) lhs rhs)
; new_lhs <- zonkLExpr env_lhs lhs
; new_rhs <- zonkLExpr env_inside rhs
- ; return (HsRule fvs name act new_bndrs new_lhs new_rhs ) }
+ ; return $ rule { rd_tmvs = new_tm_bndrs
+ , rd_lhs = new_lhs
+ , rd_rhs = new_rhs } }
where
- zonk_bndr env (L l (RuleBndr x (L loc v)))
+ zonk_tm_bndr env (L l (RuleBndr x (L loc v)))
= do { (env', v') <- zonk_it env v
; return (env', L l (RuleBndr x (L loc v'))) }
- zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
- zonk_bndr _ (L _ (XRuleBndr {})) = panic "zonk_bndr XRuleBndr"
+ zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
+ zonk_tm_bndr _ (L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"
zonk_it env v
| isId v = do { v' <- zonkIdBndr env v
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index d69357a0e2..c9d9dd0ab6 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -589,7 +589,8 @@ tcDataFamInstDecl :: Maybe ClsInstInfo
tcDataFamInstDecl mb_clsinfo
(L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = tv_names
, hsib_body =
- FamEqn { feqn_pats = pats
+ FamEqn { feqn_bndrs = mb_bndrs
+ , feqn_pats = pats
, feqn_tycon = fam_tc_name
, feqn_fixity = fixity
, feqn_rhs = HsDataDefn { dd_ND = new_or_data
@@ -608,7 +609,7 @@ tcDataFamInstDecl mb_clsinfo
-- Kind check type patterns
; let mb_kind_env = thdOf3 <$> mb_clsinfo
- ; tcFamTyPats fam_tc mb_clsinfo tv_names pats
+ ; tcFamTyPats fam_tc mb_clsinfo tv_names mb_bndrs pats
(kcDataDefn mb_kind_env decl) $
\tvs pats res_kind ->
do { stupid_theta <- solveEqualities $ tcHsContext ctxt
@@ -710,7 +711,7 @@ tcDataFamInstDecl mb_clsinfo
= go pats (tv : etad_tvs)
go pats etad_tvs = (reverse pats, etad_tvs)
- pp_hs_pats = pprFamInstLHS fam_tc_name pats fixity (unLoc ctxt) m_ksig
+ pp_hs_pats = pprFamInstLHS fam_tc_name mb_bndrs pats fixity (unLoc ctxt) m_ksig
tcDataFamInstDecl _
(L _ (DataFamInstDecl
@@ -1666,8 +1667,8 @@ mkDefMethBind clas inst_tys sel_id dm_name
; return (bind, inline_prags) }
where
mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
- mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy
- $ noLoc $ XHsType $ NHsCoreTy ty) fun)
+ mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy
+ $ noLoc $ XHsType $ NHsCoreTy ty))
-- NB: use visible type application
-- See Note [Default methods in instances]
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index ed797d389c..c8d0075bcf 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -406,7 +406,7 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
-- Type signatures in patterns
-- See Note [Pattern coercions] below
-tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside
+tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
= do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
sig_ty pat_ty
-- Using tcExtendNameTyVarEnv is appropriate here (not scopeTyVars2)
@@ -417,7 +417,7 @@ tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside
tcExtendNameTyVarEnv tv_binds $
tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
; pat_ty <- readExpType pat_ty
- ; return (mkHsWrapPat wrap (SigPat inner_ty pat') pat_ty, res) }
+ ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
------------------------
-- Lists, tuples, arrays
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 8f59e39a4f..e86ff3c34b 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -1007,7 +1007,7 @@ tcPatToExpr name args pat = go pat
InfixCon l r -> mkPrefixConExpr con [l,r]
RecCon fields -> mkRecordConExpr con fields
- go1 (SigPat _ pat) = go1 (unLoc pat)
+ go1 (SigPat _ pat _) = go1 (unLoc pat)
-- See Note [Type signatures and the builder expression]
go1 (VarPat _ (L l var))
@@ -1188,7 +1188,7 @@ tcCollectEx pat = go pat
go1 (ViewPat _ _ p) = go p
go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
goConDetails $ pat_args con
- go1 (SigPat _ p) = go p
+ go1 (SigPat _ p _) = go p
go1 (CoPat _ _ p _) = go1 p
go1 (NPlusKPat _ n k _ geq subtract)
= pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 4d2141bddf..814a580adc 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2276,7 +2276,7 @@ getGhciStepIO = do
stepTy :: LHsSigWcType GhcRn
stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
- return (noLoc $ ExprWithTySig stepTy (nlHsVar ghciStepIoMName))
+ return (noLoc $ ExprWithTySig noExt (nlHsVar ghciStepIoMName) stepTy)
isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
isGHCiMonad hsc_env ty
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index a41197521c..9d150b5bd6 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -3630,7 +3630,7 @@ exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches
exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms
exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1
-exprCtOrigin (HsAppType _ e1) = lexprCtOrigin e1
+exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1
exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
exprCtOrigin (HsPar _ e) = lexprCtOrigin e
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
index 552aa38296..56f3f07a44 100644
--- a/compiler/typecheck/TcRules.hs
+++ b/compiler/typecheck/TcRules.hs
@@ -34,7 +34,6 @@ import SrcLoc
import Outputable
import FastString
import Bag
-import Data.List( partition )
{-
Note [Typechecking rules]
@@ -52,28 +51,43 @@ an example (test simplCore/should_compile/rule2.hs) produced by Roman:
{-# RULES "foo/bar" foo = bar #-}
He wanted the rule to typecheck.
+
+Note [TcLevel in type checking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Bringing type variables into scope naturally bumps the TcLevel. Thus, we type
+check the term-level binders in a bumped level, and we must accordingly bump
+the level whenever these binders are in scope.
-}
tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]
tcRules decls = mapM (wrapLocM tcRuleDecls) decls
tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)
-tcRuleDecls (HsRules _ src decls)
+tcRuleDecls (HsRules { rds_src = src
+ , rds_rules = decls })
= do { tc_decls <- mapM (wrapLocM tcRule) decls
- ; return (HsRules noExt src tc_decls) }
+ ; return $ HsRules { rds_ext = noExt
+ , rds_src = src
+ , rds_rules = tc_decls } }
tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"
tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)
-tcRule (HsRule fvs rname@(L _ (_,name))
- act hs_bndrs lhs rhs)
+tcRule (HsRule { rd_ext = ext
+ , rd_name = rname@(L _ (_,name))
+ , rd_act = act
+ , rd_tyvs = ty_bndrs
+ , rd_tmvs = tm_bndrs
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
= addErrCtxt (ruleCtxt name) $
do { traceTc "---- Rule ------" (pprFullRuleName rname)
-- Note [Typechecking rules]
- ; (stuff, tc_lvl) <- pushTcLevelM $
- generateRuleConstraints hs_bndrs lhs rhs
+ ; (stuff,_) <- pushTcLevelM $
+ generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
- ; let ( id_bndrs, lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) = stuff
+ ; let (id_bndrs, lhs', lhs_wanted
+ , rhs', rhs_wanted, rule_ty, tc_lvl) = stuff
; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
, ppr lhs_wanted
@@ -120,58 +134,80 @@ tcRule (HsRule fvs rname@(L _ (_,name))
lhs_evs rhs_wanted
; emitImplications (lhs_implic `unionBags` rhs_implic)
- ; return (HsRule fvs rname act
- (map (noLoc . RuleBndr noExt . noLoc) (qtkvs ++ tpl_ids))
- (mkHsDictLet lhs_binds lhs')
- (mkHsDictLet rhs_binds rhs')) }
+ ; return $ HsRule { rd_ext = ext
+ , rd_name = rname
+ , rd_act = act
+ , rd_tyvs = ty_bndrs -- preserved for ppr-ing
+ , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (qtkvs ++ tpl_ids)
+ , rd_lhs = mkHsDictLet lhs_binds lhs'
+ , rd_rhs = mkHsDictLet rhs_binds rhs' } }
tcRule (XRuleDecl _) = panic "tcRule"
-generateRuleConstraints :: [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn
+generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+ -> LHsExpr GhcRn -> LHsExpr GhcRn
-> TcM ( [TcId]
, LHsExpr GhcTc, WantedConstraints
, LHsExpr GhcTc, WantedConstraints
- , TcType )
-generateRuleConstraints hs_bndrs lhs rhs
- = do { (vars, bndr_wanted) <- captureConstraints $
- tcRuleBndrs hs_bndrs
+ , TcType
+ , TcLevel )
+generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
+ = do { ((tv_bndrs, id_bndrs, lvl), bndr_wanted) <- captureConstraints $
+ tcRuleBndrs ty_bndrs tm_bndrs
-- bndr_wanted constraints can include wildcard hole
-- constraints, which we should not forget about.
-- It may mention the skolem type variables bound by
-- the RULE. c.f. Trac #10072
- ; let (id_bndrs, tv_bndrs) = partition isId vars
- ; tcExtendTyVarEnv tv_bndrs $
+ ; setTcLevel lvl $
+ tcExtendTyVarEnv tv_bndrs $
tcExtendIdEnv id_bndrs $
do { -- See Note [Solve order for RULES]
((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
; (rhs', rhs_wanted) <- captureConstraints $
tcMonoExpr rhs (mkCheckExpType rule_ty)
; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
- ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
+ ; return (id_bndrs, lhs', all_lhs_wanted
+ , rhs', rhs_wanted, rule_ty, lvl) } }
-- Slightly curious that tv_bndrs is not returned
-
-tcRuleBndrs :: [LRuleBndr GhcRn] -> TcM [Var]
-tcRuleBndrs []
- = return []
-tcRuleBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
+-- See Note [TcLevel in type checking rules]
+tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+ -> TcM ([TcTyVar],[Id],TcLevel)
+tcRuleBndrs (Just bndrs) xs
+ = do { (tys1,(tys2,tms,lvl)) <- tcExplicitTKBndrs
+ (ForAllSkol (pprHsExplicitForAll (Just bndrs)))
+ bndrs $ do { lvl <- getTcLevel
+ ; (tys,tms) <- tcRuleTmBndrs xs
+ ; return (tys,tms,lvl) }
+ ; return (tys1 ++ tys2, tms, lvl) }
+tcRuleBndrs Nothing xs
+ = do { lvl <- getTcLevel
+ ; (tys,tms) <- tcRuleTmBndrs xs
+ ; return (tys,tms,lvl) }
+
+-- See Note [TcLevel in type checking rules]
+tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
+tcRuleTmBndrs [] = return ([],[])
+tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
= do { ty <- newOpenFlexiTyVarTy
- ; vars <- tcRuleBndrs rule_bndrs
- ; return (mkLocalId name ty : vars) }
-tcRuleBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
+ ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs
+ ; return (tyvars, mkLocalId name ty : tmvars) }
+tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
-- e.g x :: a->a
-- The tyvar 'a' is brought into scope first, just as if you'd written
-- a::*, x :: a->a
+-- If there's an explicit forall, the renamer would have already reported an
+-- error for each out-of-scope type variable used
= do { let ctxt = RuleSigCtxt name
; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty
; let id = mkLocalIdOrCoVar name id_ty
-- See Note [Pattern signature binders] in TcHsType
-- The type variables scope over subsequent bindings; yuk
- ; vars <- tcExtendNameTyVarEnv tvs $
- tcRuleBndrs rule_bndrs
- ; return (map snd tvs ++ id : vars) }
-tcRuleBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleBndrs"
+ ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
+ tcRuleTmBndrs rule_bndrs
+ ; return (map snd tvs ++ tyvars, id : tmvars) }
+tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs"
ruleCtxt :: FastString -> SDoc
ruleCtxt name = text "When checking the transformation rule" <+>
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index a4f81282b3..9cef8753f9 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1391,14 +1391,17 @@ reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
-------------------------------------------
reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
-reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
+reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
+ , cab_lhs = lhs
+ , cab_rhs = rhs })
-- remove kind patterns (#8884)
- = do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+ = do { tvs' <- reifyTyVarsToMaybe tvs
+ ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
; lhs' <- reifyTypes lhs_types_only
; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
lhs_types_only lhs'
; rhs' <- reifyType rhs
- ; return (TH.TySynEqn annot_th_lhs rhs') }
+ ; return (TH.TySynEqn tvs' annot_th_lhs rhs') }
where
fam_tvs = tyConVisibleTyVars fam_tc
@@ -1612,7 +1615,7 @@ reifyClass cls
reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
reifyDefImpl n args ty =
- TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
+ TH.TySynInstD n . TH.TySynEqn Nothing (map TH.VarT args) <$> reifyType ty
tfNames :: TH.Dec -> (TH.Name, [TH.Name])
tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
@@ -1697,13 +1700,14 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
= case flavor of
SynFamilyInst ->
-- remove kind patterns (#8884)
- do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+ do { th_tvs <- reifyTyVarsToMaybe fam_tvs
+ ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
; th_lhs <- reifyTypes lhs_types_only
; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
th_lhs
; th_rhs <- reifyType rhs
; return (TH.TySynInstD (reifyName fam)
- (TH.TySynEqn annot_th_lhs th_rhs)) }
+ (TH.TySynEqn th_tvs annot_th_lhs th_rhs)) }
DataFamilyInst rep_tc ->
do { let rep_tvs = tyConTyVars rep_tc
@@ -1720,14 +1724,15 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
eta_expanded_lhs = lhs `chkAppend` etad_tys
dataCons = tyConDataCons rep_tc
isGadt = isGadtSyntaxTyCon rep_tc
+ ; th_tvs <- reifyTyVarsToMaybe fam_tvs
; cons <- mapM (reifyDataCon isGadt eta_expanded_tvs) dataCons
; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
; th_tys <- reifyTypes types_only
; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
; return $
if isNewTyCon rep_tc
- then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []
- else TH.DataInstD [] fam' annot_th_tys Nothing cons []
+ then TH.NewtypeInstD [] fam' th_tvs annot_th_tys Nothing (head cons) []
+ else TH.DataInstD [] fam' th_tvs annot_th_tys Nothing cons []
}
where
fam_tc = famInstTyCon inst
@@ -1815,6 +1820,10 @@ reifyTyVars tvs = mapM reify_tv tvs
kind = tyVarKind tv
name = reifyName tv
+reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr])
+reifyTyVarsToMaybe [] = pure Nothing
+reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys
+
{-
Note [Kind annotations on TyConApps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 49c6082ba4..ea1299825f 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1254,7 +1254,7 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name
-- type default LHS can mention *different* type variables than the
-- enclosing class. So it's treated more as a freestanding beast.
; (pats', rhs_ty)
- <- tcFamTyPats fam_tc Nothing all_vars pats
+ <- tcFamTyPats fam_tc Nothing all_vars Nothing pats
(kcTyFamEqnRhs Nothing rhs) $
\tvs pats rhs_kind ->
do { rhs_ty <- solveEqualities $
@@ -1274,7 +1274,7 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name
-- in checkValidClass
}
tcDefaultAssocDecl _ [L _ (XFamEqn _)] = panic "tcDefaultAssocDecl"
-tcDefaultAssocDecl _ [L _ (FamEqn _ (L _ _) (XLHsQTyVars _) _ _)]
+tcDefaultAssocDecl _ [L _ (FamEqn _ (L _ _) _ (XLHsQTyVars _) _ _)]
= panic "tcDefaultAssocDecl"
{- Note [Type-checking default assoc decls]
@@ -1527,22 +1527,24 @@ tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"
-------------------------
kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
kcTyFamInstEqn tc_fam_tc
- (L loc (HsIB { hsib_ext = tv_names
+ (L loc (HsIB { hsib_ext = imp_vars
, hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name
+ , feqn_bndrs = mb_expl_bndrs
, feqn_pats = pats
, feqn_rhs = hs_ty }}))
= setSrcSpan loc $
do { traceTc "kcTyFamInstEqn" (vcat
[ text "tc_name =" <+> ppr eqn_tc_name
, text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
- , text "hsib_vars =" <+> ppr tv_names
+ , text "hsib_vars =" <+> ppr imp_vars
+ , text "feqn_bndrs =" <+> ppr mb_expl_bndrs
, text "feqn_pats =" <+> ppr pats ])
; checkTc (fam_name == eqn_tc_name)
(wrongTyFamName fam_name eqn_tc_name)
-- this check reports an arity error instead of a kind error; easier for user
; checkTc (pats `lengthIs` vis_arity) $
wrongNumberOfParmsErr vis_arity
- ; kcFamTyPats tc_fam_tc tv_names pats $ \ rhs_kind ->
+ ; kcFamTyPats tc_fam_tc imp_vars mb_expl_bndrs pats $ \ rhs_kind ->
discardResult $ kcTyFamEqnRhs Nothing hs_ty rhs_kind }
where
fam_name = tyConName tc_fam_tc
@@ -1580,13 +1582,14 @@ tcTyFamInstEqn :: TcTyCon -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
-- Needs to be here, not in TcInstDcls, because closed families
-- (typechecked here) have TyFamInstEqns
tcTyFamInstEqn fam_tc mb_clsinfo
- (L loc (HsIB { hsib_ext = tv_names
+ (L loc (HsIB { hsib_ext = imp_vars
, hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name
+ , feqn_bndrs = mb_expl_bndrs
, feqn_pats = pats
, feqn_rhs = hs_ty }}))
= ASSERT( getName fam_tc == eqn_tc_name )
setSrcSpan loc $
- tcFamTyPats fam_tc mb_clsinfo tv_names pats
+ tcFamTyPats fam_tc mb_clsinfo imp_vars mb_expl_bndrs pats
(kcTyFamEqnRhs mb_clsinfo hs_ty) $
\tvs pats res_kind ->
do { traceTc "tcTyFamInstEqn {" (ppr eqn_tc_name <+> ppr pats)
@@ -1617,6 +1620,7 @@ kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars
kcDataDefn mb_kind_env
(DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = fam_name
+ , feqn_bndrs = mb_bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = HsDataDefn { dd_ctxt = ctxt
@@ -1664,10 +1668,10 @@ kcDataDefn mb_kind_env
; return (new_args, lhs_ki) }
where
bogus_ty = pprPanic "kcDataDefn" (ppr fam_name <+> ppr pats)
- pp_fam_app = pprFamInstLHS fam_name pats fixity (unLoc ctxt) mb_kind
+ pp_fam_app = pprFamInstLHS fam_name mb_bndrs pats fixity (unLoc ctxt) mb_kind
kcDataDefn _ (DataFamInstDecl (XHsImplicitBndrs _)) _
= panic "kcDataDefn"
-kcDataDefn _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ (XHsDataDefn _)))) _
+kcDataDefn _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ _ (XHsDataDefn _)))) _
= panic "kcDataDefn"
kcDataDefn _ (DataFamInstDecl (HsIB _ (XFamEqn _))) _
= panic "kcDataDefn"
@@ -1718,12 +1722,14 @@ two bad things could happen:
-----------------
kcFamTyPats :: TcTyCon
-> [Name]
+ -> Maybe [LHsTyVarBndr GhcRn]
-> HsTyPats GhcRn
-> (TcKind -> TcM ())
-> TcM ()
-kcFamTyPats tc_fam_tc tv_names arg_pats kind_checker
+kcFamTyPats tc_fam_tc imp_vars mb_expl_bndrs arg_pats kind_checker
= discardResult $
- kcImplicitTKBndrs tv_names $
+ kcImplicitTKBndrs imp_vars $
+ kcExplicitTKBndrs (fromMaybe [] mb_expl_bndrs) $
do { let name = tyConName tc_fam_tc
loc = nameSrcSpan name
lhs_fun = L loc (HsTyVar noExt NotPromoted (L loc name))
@@ -1739,6 +1745,7 @@ kcFamTyPats tc_fam_tc tv_names arg_pats kind_checker
tcFamTyPats :: TyCon
-> Maybe ClsInstInfo
-> [Name] -- Implicitly bound kind/type variable names
+ -> Maybe [LHsTyVarBndr GhcRn]
-> HsTyPats GhcRn -- Type patterns
-> (TcKind -> TcM ([TcType], TcKind))
-- kind-checker for RHS
@@ -1759,7 +1766,7 @@ tcFamTyPats :: TyCon
-- In that case, the type variable 'a' will *already be in scope*
-- (and, if C is poly-kinded, so will its kind parameter).
tcFamTyPats fam_tc mb_clsinfo
- tv_names arg_pats kind_checker thing_inside
+ imp_vars mb_expl_bndrs arg_pats kind_checker thing_inside
= do { -- First, check the arity.
-- If we wait until validity checking, we'll get kind
-- errors below when an arity error will be much easier to
@@ -1774,10 +1781,10 @@ tcFamTyPats fam_tc mb_clsinfo
wrongNumberOfParmsErr vis_arity
-- report only explicit arguments
- ; (fam_used_tvs, (typats, (more_typats, res_kind)))
+ ; (imp_tvs, (exp_tvs, (typats, (more_typats, res_kind))))
<- solveEqualities $ -- See Note [Constraints in patterns]
- tcImplicitQTKBndrs FamInstSkol tv_names $
- -- See Note [Kind-checking tyvar binders for associated types]
+ tcImplicitQTKBndrs FamInstSkol imp_vars $
+ tcExplicitTKBndrs FamInstSkol (fromMaybe [] mb_expl_bndrs) $
do { let loc = nameSrcSpan fam_name
lhs_fun = L loc (HsTyVar noExt NotPromoted
(L loc fam_name))
@@ -1827,19 +1834,24 @@ tcFamTyPats fam_tc mb_clsinfo
-- bit is cleverer.
; traceTc "tcFamTyPats" (ppr (getName fam_tc)
+ $$ ppr mb_expl_bndrs
$$ ppr all_pats $$ ppr qtkvs)
-- See Note [Free-floating kind vars] in TcHsType
; let all_mentioned_tvs = mkVarSet qtkvs
-- qtkvs has all the tyvars bound by LHS
-- type patterns
- unmentioned_tvs = filterOut (`elemVarSet` all_mentioned_tvs)
- fam_used_tvs
+ unmentioned_imp_tvs = filterOut (`elemVarSet` all_mentioned_tvs) imp_tvs
-- If there are tyvars left over, we can
-- assume they're free-floating, since they
-- aren't bound by a type pattern
; checkNoErrs $ reportFloatingKvs fam_name flav
- qtkvs unmentioned_tvs
+ qtkvs unmentioned_imp_tvs
+
+ -- Error if exp_tvs contains anything that is still unused.
+ -- See Note [Unused explicitly bound variables in a family pattern]
+ ; let unmentioned_exp_tvs = filterOut (`elemVarSet` all_mentioned_tvs) exp_tvs
+ ; checkNoErrs $ mapM_ (unusedExplicitForAllErr . Var.varName) unmentioned_exp_tvs
; scopeTyVars FamInstSkol qtkvs $
-- Extend envt with TcTyVars not TyVars, because the
@@ -1851,8 +1863,34 @@ tcFamTyPats fam_tc mb_clsinfo
flav = tyConFlavour fam_tc
vis_arity = length (tyConVisibleTyVars fam_tc)
+unusedExplicitForAllErr :: Name -> RnM ()
+unusedExplicitForAllErr n = addErrAt (nameSrcSpan n) $
+ text "Explicitly quantified but not used in LHS pattern: type variable"
+ <+> quotes (ppr n)
{-
+
+Note [Unused explicitly bound variables in a family pattern]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Why is 'unusedExplicitForAllErr' not just a warning?
+
+Consider the following examples:
+
+ type instance F a = Maybe b
+ type instance forall b. F a = Bool
+ type instance forall b. F a = Maybe b
+
+In every case, b is a type variable not determined by the LHS pattern. The
+first is caught by the renamer, but we catch the last two here. Perhaps one
+could argue that the second should be accepted, albeit with a warning, but
+consider the fact that in a type family instance, there is no way to interact
+with such a varable. At least with @x :: forall a. Int@ we can use visibile
+type application, like @x \@Bool 1@. (Of course it does nothing, but it is
+permissible.) In the type family case, the only sensible explanation is that
+the user has made a mistake -- thus we throw an error.
+
+
Note [Constraints in patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB: This isn't the whole story. See comment in tcFamTyPats.
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 366dd98052..196350348f 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -7572,6 +7572,17 @@ instance for ``GMap`` is ::
In this example, the declaration has only one variant. In general, it
can be any number.
+When :extension:`ExplicitForAll` is enabled, type or kind variables used on
+the left hand side can be explicitly bound. For example: ::
+
+ data instance forall a (b :: Proxy a). F (Proxy b) = FProxy Bool
+
+When an explicit ``forall`` is present, all *type* variables mentioned must
+be bound by the ``forall``. Kind variables will be implicitly bound if
+necessary, for example: ::
+
+ data instance forall (a :: k). F a = FOtherwise
+
When the flag :ghc-flag:`-Wunused-type-patterns` is enabled, type
variables that are mentioned in the patterns on the left hand side, but not
used on the right hand side are reported. Variables that occur multiple times
@@ -7585,6 +7596,9 @@ This resembles the wildcards that can be used in
No error messages reporting the inferred types are generated, nor does
the extension :extension:`PartialTypeSignatures` have any effect.
+A type or kind variable explicitly bound using :extension:`ExplicitForAll` but
+not used on the left hand side will generate an error, not a warning.
+
Data and newtype instance declarations are only permitted when an
appropriate family declaration is in scope - just as a class instance
declaration requires the class declaration to be visible. Moreover, each
@@ -7737,6 +7751,10 @@ with underscores to avoid warnings when the
:ghc-flag:`-Wunused-type-patterns` flag is enabled. The same rules apply
as for :ref:`data-instance-declarations`.
+Also in the same way as :ref:`data-instance-declarations`, when
+:extension:`ExplicitForAll` is enabled, type and kind variables can be
+explicilty bound in a type instance declaration.
+
Type family instance declarations are only legitimate when an
appropriate family declaration is in scope - just like class instances
require the class declaration to be visible. Moreover, each instance
@@ -7771,8 +7789,14 @@ Note that GHC must be sure that ``a`` cannot unify with ``Int`` or
their code, GHC will not be able to simplify the type. After all, ``a``
might later be instantiated with ``Int``.
-A closed type family's equations have the same restrictions as the
-equations for open type family instances.
+A closed type family's equations have the same restrictions and extensions as
+the equations for open type family instances. For instance, when
+:extension:`ExplicitForAll` is enabled, type or kind variables used on the
+left hand side of an equation can be explicitly bound, such as in: ::
+
+ type family R a where
+ forall t a. R (t a) = [a]
+ forall a. R a = a
A closed type family may be declared with no equations. Such closed type
families are opaque type-level definitions that will never reduce, are
@@ -8000,7 +8024,7 @@ Hence, the following contrived example is admissible: ::
Here ``c`` and ``a`` are class parameters, but the type is also indexed
on a third parameter ``x``.
-.. _assoc-data-inst:
+.. _assoc-inst:
Associated instances
~~~~~~~~~~~~~~~~~~~~
@@ -8075,6 +8099,15 @@ Note the following points:
cannot give any *subsequent* instances for ``(GMap Flob ...)``, this
facility is most useful when the free indexed parameter is of a kind
with a finite number of alternatives (unlike ``Type``).
+
+- When :extension:`ExplicitForAll` is enabled, type and kind variables can be
+ explicily bound in associated data or type family instances in the same way
+ (and with the same restrictions) as :ref:`data-instance-declarations` or
+ :ref:`type-instance-declarations`. For example, adapting the above, the
+ following is accepted: ::
+
+ instance Eq (Elem [e]) => Collects [e] where
+ type forall e. Elem [e] = e
.. _assoc-decl-defs:
@@ -8111,6 +8144,10 @@ Note the following points:
variables that are explicitly bound on the left hand side. This restriction
is relaxed for *kind* variables, however, as the right hand side is allowed
to mention kind variables that are implicitly bound on the left hand side.
+
+ Because of this, unlike :ref:`assoc-inst`, explicit binding of type/kind
+ variables in default declarations is not permitted by
+ :extension:`ExplicitForAll`.
- Unlike the associated type family declaration itself, the type variables of
the default instance are independent of those of the parent class.
@@ -9989,6 +10026,10 @@ means this: ::
The two are treated identically, except that the latter may bring type variables
into scope (see :ref:`scoped-type-variables`).
+This extension also enables explicit quantification of type and kind variables
+in :ref:`data-instance-declarations`, :ref:`type-instance-declarations`,
+:ref:`closed-type-families`, :ref:`assoc-inst`, and :ref:`rewrite-rules`.
+
Notes:
- With :extension:`ExplicitForAll`, ``forall`` becomes a keyword; you can't use ``forall`` as a
@@ -15172,7 +15213,7 @@ From a syntactic point of view:
is never run by GHC, but is nevertheless parsed, typechecked etc, so
that it is available to the plugin.
-- Each variable mentioned in a rule must either be in scope (e.g.
+- Each (term) variable mentioned in a rule must either be in scope (e.g.
``map``), or bound by the ``forall`` (e.g. ``f``, ``g``, ``xs``). The
variables bound by the ``forall`` are called the *pattern* variables.
They are separated by spaces, just like in a type ``forall``.
@@ -15186,6 +15227,25 @@ From a syntactic point of view:
Since ``g`` has a polymorphic type, it must have a type signature.
+- If :extension:`ExplicitForAll` is enabled, type/kind variables can also be
+ explicitly bound. For example: ::
+
+ {-# RULES "id" forall a. forall (x :: a). id @a x = x #-}
+
+ When a type-level explicit ``forall`` is present, each type/kind variable
+ mentioned must now also be either in scope or bound by the ``forall``. In
+ particular, unlike some other places in Haskell, this means free kind
+ variables will not be implicitly bound. For example: ::
+
+ "this_is_bad" forall (c :: k). forall (x :: Proxy c) ...
+ "this_is_ok" forall k (c :: k). forall (x :: Proxy c) ...
+
+ When bound type/kind variables are needed, both foralls must always be
+ included, though if no pattern variables are needed, the second can be left
+ empty. For example: ::
+
+ {-# RULES "map/id" forall a. forall. map (id @a) = id @[a] #-}
+
- The left hand side of a rule must consist of a top-level variable
applied to arbitrary expressions. For example, this is *not* OK: ::
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index f603a4cf28..f0c4ac4fd5 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -1503,7 +1503,7 @@ of ``-W(no-)*``.
do { mapM_ popInt xs ; return 10 }
.. ghc-flag:: -Wunused-type-patterns
- :shortdesc: warn about unused type variables which arise from patterns
+ :shortdesc: warn about unused type variables which arise from patterns in
in type family and data family instances
:type: dynamic
:reverse: -Wno-unused-type-patterns
@@ -1513,22 +1513,30 @@ of ``-W(no-)*``.
single: unused type patterns, warning
single: type patterns, unused
- Report all unused type variables which arise from patterns in type family
- and data family instances. For instance: ::
+ Report all unused implicitly bound type variables which arise from
+ patterns in type family and data family instances. For instance: ::
type instance F x y = []
- would report ``x`` and ``y`` as unused. The warning is suppressed if the
- type variable name begins with an underscore, like so: ::
+ would report ``x`` and ``y`` as unused on the right hand side. The warning
+ is suppressed if the type variable name begins with an underscore, like
+ so: ::
type instance F _x _y = []
+ When :extension:`ExplicitForAll` is enabled, explicitly quantified type
+ variables may also be identified as unused. For instance: ::
+
+ type instance forall x y. F x y = []
+
+ would still report ``x`` and ``y`` as unused on the right hand side
+
Unlike :ghc-flag:`-Wunused-matches`, :ghc-flag:`-Wunused-type-patterns` is
not implied by :ghc-flag:`-Wall`. The rationale for this decision is that
unlike term-level pattern names, type names are often chosen expressly for
documentation purposes, so using underscores in type names can make the
documentation harder to read.
-
+
.. ghc-flag:: -Wunused-foralls
:shortdesc: warn about type variables in user-written
``forall``\\s that are unused
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 1f862de4cb..bfcaabf5e7 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1527,7 +1527,7 @@ defineMacro overwrite s = do
body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
`mkHsApp` (nlHsPar expr)
tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
- new_expr = L (getLoc expr) $ ExprWithTySig tySig body
+ new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig
hv <- GHC.compileParsedExprRemote new_expr
let newCmd = Command { cmdName = macro_name
@@ -1591,7 +1591,7 @@ getGhciStepIO = do
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar (getRdrName ghciStepIoMName)
tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)
- return $ noLoc $ ExprWithTySig tySig body
+ return $ noLoc $ ExprWithTySig noExt body tySig
-----------------------------------------------------------------------------
-- :check
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 778e6c0553..67a8773ecc 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -126,11 +126,13 @@ import Language.Haskell.TH.Lib.Internal hiding
, dataD
, newtypeD
, classD
+ , pragRuleD
, dataInstD
, newtypeInstD
, dataFamilyD
, openTypeFamilyD
, closedTypeFamilyD
+ , tySynEqn
, forallC
, forallT
@@ -192,6 +194,14 @@ classD ctxt cls tvs fds decs =
ctxt1 <- ctxt
return $ ClassD ctxt1 cls tvs fds decs1
+pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
+pragRuleD n bndrs lhs rhs phases
+ = do
+ bndrs1 <- sequence bndrs
+ lhs1 <- lhs
+ rhs1 <- rhs
+ return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases
+
dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
-> DecQ
dataInstD ctxt tc tys ksig cons derivs =
@@ -200,7 +210,7 @@ dataInstD ctxt tc tys ksig cons derivs =
tys1 <- sequence tys
cons1 <- sequence cons
derivs1 <- sequence derivs
- return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1)
+ return (DataInstD ctxt1 tc Nothing tys1 ksig cons1 derivs1)
newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ]
-> DecQ
@@ -210,7 +220,7 @@ newtypeInstD ctxt tc tys ksig con derivs =
tys1 <- sequence tys
con1 <- con
derivs1 <- sequence derivs
- return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1)
+ return (NewtypeInstD ctxt1 tc Nothing tys1 ksig con1 derivs1)
dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ
dataFamilyD tc tvs kind
@@ -227,6 +237,13 @@ closedTypeFamilyD tc tvs result injectivity eqns =
do eqns1 <- sequence eqns
return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1)
+tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
+tySynEqn lhs rhs =
+ do
+ lhs1 <- sequence lhs
+ rhs1 <- rhs
+ return (TySynEqn Nothing lhs1 rhs1)
+
forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 989e8168ba..11391da95f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -469,13 +469,15 @@ pragSpecInstD ty
ty1 <- ty
return $ PragmaD $ SpecialiseInstP ty1
-pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
-pragRuleD n bndrs lhs rhs phases
+pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ
+ -> Phases -> DecQ
+pragRuleD n ty_bndrs tm_bndrs lhs rhs phases
= do
- bndrs1 <- sequence bndrs
+ ty_bndrs1 <- traverse sequence ty_bndrs
+ tm_bndrs1 <- sequence tm_bndrs
lhs1 <- lhs
rhs1 <- rhs
- return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
+ return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases
pragAnnD :: AnnTarget -> ExpQ -> DecQ
pragAnnD target expr
@@ -489,27 +491,29 @@ pragLineD line file = return $ PragmaD $ LineP line file
pragCompleteD :: [Name] -> Maybe Name -> DecQ
pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
-dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> [ConQ]
- -> [DerivClauseQ] -> DecQ
-dataInstD ctxt tc tys ksig cons derivs =
+dataInstD :: CxtQ -> Name -> (Maybe [TyVarBndrQ]) -> [TypeQ] -> Maybe KindQ
+ -> [ConQ] -> [DerivClauseQ] -> DecQ
+dataInstD ctxt tc mb_bndrs tys ksig cons derivs =
do
- ctxt1 <- ctxt
- tys1 <- sequenceA tys
- ksig1 <- sequenceA ksig
- cons1 <- sequenceA cons
- derivs1 <- sequenceA derivs
- return (DataInstD ctxt1 tc tys1 ksig1 cons1 derivs1)
-
-newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> ConQ
- -> [DerivClauseQ] -> DecQ
-newtypeInstD ctxt tc tys ksig con derivs =
+ ctxt1 <- ctxt
+ mb_bndrs1 <- traverse sequence mb_bndrs
+ tys1 <- sequenceA tys
+ ksig1 <- sequenceA ksig
+ cons1 <- sequenceA cons
+ derivs1 <- sequenceA derivs
+ return (DataInstD ctxt1 tc mb_bndrs1 tys1 ksig1 cons1 derivs1)
+
+newtypeInstD :: CxtQ -> Name -> (Maybe [TyVarBndrQ]) -> [TypeQ] -> Maybe KindQ
+ -> ConQ -> [DerivClauseQ] -> DecQ
+newtypeInstD ctxt tc mb_bndrs tys ksig con derivs =
do
- ctxt1 <- ctxt
- tys1 <- sequenceA tys
- ksig1 <- sequenceA ksig
- con1 <- con
- derivs1 <- sequence derivs
- return (NewtypeInstD ctxt1 tc tys1 ksig1 con1 derivs1)
+ ctxt1 <- ctxt
+ mb_bndrs1 <- traverse sequence mb_bndrs
+ tys1 <- sequenceA tys
+ ksig1 <- sequenceA ksig
+ con1 <- con
+ derivs1 <- sequence derivs
+ return (NewtypeInstD ctxt1 tc mb_bndrs1 tys1 ksig1 con1 derivs1)
tySynInstD :: Name -> TySynEqnQ -> DecQ
tySynInstD tc eqn =
@@ -580,12 +584,13 @@ implicitParamBindD n e =
e' <- e
return $ ImplicitParamBindD n e'
-tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
-tySynEqn lhs rhs =
+tySynEqn :: (Maybe [TyVarBndrQ]) -> [TypeQ] -> TypeQ -> TySynEqnQ
+tySynEqn mb_bndrs lhs rhs =
do
+ mb_bndrs1 <- traverse sequence mb_bndrs
lhs1 <- sequence lhs
rhs1 <- rhs
- return (TySynEqn lhs1 rhs1)
+ return (TySynEqn mb_bndrs1 lhs1 rhs1)
cxt :: [PredQ] -> CxtQ
cxt = sequence
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 7df8c98643..138cf62b24 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -347,18 +347,21 @@ ppr_dec isTop (DataFamilyD tc tvs kind)
| otherwise = empty
maybeKind | (Just k') <- kind = dcolon <+> ppr k'
| otherwise = empty
-ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs)
- = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs
+ppr_dec isTop (DataInstD ctxt tc bndrs tys ksig cs decs)
+ = ppr_data (maybeInst <+> ppr_bndrs bndrs) ctxt tc
+ (sep (map pprParendType tys)) ksig cs decs
where
maybeInst | isTop = text "instance"
| otherwise = empty
-ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs)
- = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs
+ppr_dec isTop (NewtypeInstD ctxt tc bndrs tys ksig c decs)
+ = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) ctxt tc
+ (sep (map pprParendType tys)) ksig c decs
where
maybeInst | isTop = text "instance"
| otherwise = empty
-ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
- = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
+ppr_dec isTop (TySynInstD tc (TySynEqn mb_bndrs tys rhs))
+ = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) tc
+ (sep (map pprParendType tys)) rhs
where
maybeInst | isTop = text "instance"
| otherwise = empty
@@ -371,8 +374,9 @@ ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
= hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
nestDepth (vcat (map ppr_eqn eqns))
where
- ppr_eqn (TySynEqn lhs rhs)
- = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
+ ppr_eqn (TySynEqn mb_bndrs lhs rhs)
+ = ppr_bndrs mb_bndrs <+> ppr tc <+> sep (map pprParendType lhs)
+ <+> text "=" <+> ppr rhs
ppr_dec _ (RoleAnnotD name roles)
= hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
ppr_dec _ (StandaloneDerivD ds cxt ty)
@@ -484,6 +488,10 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
maybeInj | (Just inj') <- inj = ppr inj'
| otherwise = empty
+ppr_bndrs :: Maybe [TyVarBndr] -> Doc
+ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."
+ppr_bndrs Nothing = empty
+
------------------------------
instance Ppr FunDep where
ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
@@ -535,14 +543,19 @@ instance Ppr Pragma where
<+> text "#-}"
ppr (SpecialiseInstP inst)
= text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
- ppr (RuleP n bndrs lhs rhs phases)
+ ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)
= sep [ text "{-# RULES" <+> pprString n <+> ppr phases
- , nest 4 $ ppr_forall <+> ppr lhs
+ , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs
+ <+> ppr lhs
, nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
- where ppr_forall | null bndrs = empty
- | otherwise = text "forall"
- <+> fsep (map ppr bndrs)
- <+> char '.'
+ where ppr_ty_forall Nothing = empty
+ ppr_ty_forall (Just bndrs) = text "forall"
+ <+> fsep (map ppr bndrs)
+ <+> char '.'
+ ppr_tm_forall Nothing | null tm_bndrs = empty
+ ppr_tm_forall _ = text "forall"
+ <+> fsep (map ppr tm_bndrs)
+ <+> char '.'
ppr (AnnP tgt expr)
= text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
where target1 ModuleAnnotation = text "module"
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 7ee81c8d6e..b75a04867b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1711,14 +1711,18 @@ data Dec
(Maybe Kind)
-- ^ @{ data family T a b c :: * }@
- | DataInstD Cxt Name [Type]
+ | DataInstD Cxt Name
+ (Maybe [TyVarBndr]) -- Quantified type vars
+ [Type]
(Maybe Kind) -- Kind signature
[Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x]
-- = A x | B (T x)
-- deriving (Z,W)
-- deriving stock Eq }@
- | NewtypeInstD Cxt Name [Type]
+ | NewtypeInstD Cxt Name
+ (Maybe [TyVarBndr]) -- Quantified type vars
+ [Type]
(Maybe Kind) -- Kind signature
Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x]
-- = A (B x)
@@ -1837,7 +1841,7 @@ data TypeFamilyHead =
-- | One equation of a type family instance or closed type family. The
-- arguments are the left-hand-side type patterns and the right-hand-side
-- result.
-data TySynEqn = TySynEqn [Type] Type
+data TySynEqn = TySynEqn (Maybe [TyVarBndr]) [Type] Type
deriving( Show, Eq, Ord, Data, Generic )
data FunDep = FunDep [Name] [Name]
@@ -1857,7 +1861,7 @@ data Safety = Unsafe | Safe | Interruptible
data Pragma = InlineP Name Inline RuleMatch Phases
| SpecialiseP Name Type (Maybe Inline) Phases
| SpecialiseInstP Type
- | RuleP String [RuleBndr] Exp Exp Phases
+ | RuleP String (Maybe [TyVarBndr]) [RuleBndr] Exp Exp Phases
| AnnP AnnTarget Exp
| LineP Int String
| CompleteP [Name] (Maybe Name)
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index c3d6c252e7..de8b96f633 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -1,5 +1,17 @@
# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
+## 2.15.0.0 *TBA*
+
+ * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`,
+ and `RuleP` now all have a `Maybe [TyVarBndr]` argument, which contains a
+ list of quantified type variables if an explicit `forall` is present, and
+ `Nothing` otherwise.
+
+ Correspondingly, in `Language.Haskell.TH.Lib.Internal`, `pragRuleD`,
+ `dataInstD`, `newtypeInstD`, and `tySynEqn` now all have a
+ `Maybe [TyVarBndrQ]` argument. Non-API-breaking versions of these
+ functions can be found in `Language.Haskell.TH.Lib`.
+
## 2.14.0.0 *TBA*
* Introduce an `addForeignFilePath` function, as well as a corresponding
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
index 96702f5235..1b5803b817 100644
--- a/testsuite/tests/ghc-api/annotations/stringSource.hs
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -73,7 +73,7 @@ testOneFile libdir fileName = do
doRuleDecl :: RuleDecl GhcPs
-> [(String,[Located (SourceText,FastString)])]
- doRuleDecl (HsRule _ ss _ _ _ _) = [("r",[ss])]
+ doRuleDecl (HsRule _ ss _ _ _ _ _) = [("r",[ss])]
doCCallTarget :: CCallTarget
-> [(String,[Located (SourceText,FastString)])]
diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs
index 5a50af85f1..232d47ff98 100644
--- a/testsuite/tests/ghc-api/annotations/t11430.hs
+++ b/testsuite/tests/ghc-api/annotations/t11430.hs
@@ -60,11 +60,11 @@ testOneFile libdir fileName = do
doRuleDecl :: RuleDecl GhcPs
-> [(String,[String])]
- doRuleDecl (HsRule _ _ (ActiveBefore (SourceText ss) _) _ _ _)
+ doRuleDecl (HsRule _ _ (ActiveBefore (SourceText ss) _) _ _ _ _)
= [("rb",[ss])]
- doRuleDecl (HsRule _ _ (ActiveAfter (SourceText ss) _) _ _ _)
+ doRuleDecl (HsRule _ _ (ActiveAfter (SourceText ss) _) _ _ _ _)
= [("ra",[ss])]
- doRuleDecl (HsRule _ _ _ _ _ _) = []
+ doRuleDecl (HsRule _ _ _ _ _ _ _) = []
doHsExpr :: HsExpr GhcPs -> [(String,[String])]
doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])]
diff --git a/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams1.hs b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams1.hs
new file mode 100644
index 0000000000..067127cf8a
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams1.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+
+module ExplicitForAllFams where
+
+import Data.Proxy
+import Data.Kind
+
+-- From Proposal 0007
+
+data family F a
+data instance forall (x :: Bool). F (Proxy x) = MkF
+
+class C a where
+ type G a b
+instance forall a. C [a] where
+ type forall b. G [a] b = Int
+
+type family H a b where
+ forall x y. H [x] (Proxy y) = Double
+ forall z. H z z = Bool
+
+-- More tests
+
+type family D a b where
+ forall (a :: Type -> Type) (b :: a Int) (c :: k). D (Proxy b) (Proxy c) = ()
+ forall (a :: Bool) (b :: Proxy a). D (Proxy b) () = Int
+ forall (a :: Type). D a a = Maybe a
diff --git a/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.hs b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.hs
new file mode 100644
index 0000000000..2b8e2cbed8
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams2 where
+
+import Data.Kind (Type)
+
+-- Even more tests
+
+type family CF a b where
+ forall x y. CF [x] (Maybe y) = (x,y)
+ forall (z :: Type). CF z z = Bool
+ forall. CF _ _ = ()
+
+type family OF a
+type instance forall a b. OF (Maybe a, Either a b) = Either [a] b
+
+data family DF a
+data instance forall a b. DF (Maybe a, Either a b) = DF a a b
+
+data family NF a
+newtype instance forall a b. NF (Maybe a, Either a b) = NF { unNF :: Either [a] b }
+
+class Cl a where
+ type AT a b
+ data AD a b
+instance forall a. Cl (Maybe a) where
+ type forall b. AT (Maybe a) b = b
+ data forall b. AD (Maybe a) b = AD b
+
+-- Should produce warnings
+
+type family N a where
+ forall t a. N (t a) = [a]
+ forall a. N a = ()
+
+type family N' a where
+ N' (t a) = [a]
+ N' a = ()
diff --git a/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr
new file mode 100644
index 0000000000..0d2eaae027
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr
@@ -0,0 +1,12 @@
+
+ExplicitForAllFams2.hs:34:10: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘t’
+
+ExplicitForAllFams2.hs:35:10: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘a’
+
+ExplicitForAllFams2.hs:38:7: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘t’
+
+ExplicitForAllFams2.hs:39:6: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘a’
diff --git a/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr b/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr
index 5881145e23..833315e6be 100644
--- a/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr
+++ b/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr
@@ -1,12 +1,12 @@
-UnusedTyVarWarnings.hs:8:5: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘b’
+UnusedTyVarWarnings.hs:8:7: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘b’
-UnusedTyVarWarnings.hs:11:18: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘b’
+UnusedTyVarWarnings.hs:11:20: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘b’
UnusedTyVarWarnings.hs:27:5: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘a’
+ Defined but not used on the right hand side: type variable ‘a’
-UnusedTyVarWarnings.hs:33:17: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘b’
+UnusedTyVarWarnings.hs:33:19: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘b’
diff --git a/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr b/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr
index 6cbc861b28..9049ddf696 100644
--- a/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr
+++ b/testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr
@@ -1,12 +1,12 @@
-UnusedTyVarWarningsNamedWCs.hs:8:5: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘b’
+UnusedTyVarWarningsNamedWCs.hs:8:7: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘b’
-UnusedTyVarWarningsNamedWCs.hs:11:18: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘b’
+UnusedTyVarWarningsNamedWCs.hs:11:20: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘b’
UnusedTyVarWarningsNamedWCs.hs:27:5: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘a’
+ Defined but not used on the right hand side: type variable ‘a’
-UnusedTyVarWarningsNamedWCs.hs:33:17: warning: [-Wunused-type-patterns]
- Defined but not used: type variable ‘b’
+UnusedTyVarWarningsNamedWCs.hs:33:19: warning: [-Wunused-type-patterns]
+ Defined but not used on the right hand side: type variable ‘b’
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 5bfbca4db9..d95826c362 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -94,6 +94,9 @@ test('GivenCheckSwap', normal, compile, [''])
test('GivenCheckDecomp', normal, compile, [''])
test('GivenCheckTop', normal, compile, [''])
+test('ExplicitForAllFams1', normal, compile, [''])
+test('ExplicitForAllFams2', normal, compile, ['-Wunused-foralls -Wunused-type-patterns'])
+
# A very delicate test
test('Gentle', normal, compile, [''])
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.hs b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.hs
new file mode 100644
index 0000000000..53a0e2ab32
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams3 where
+
+type family H a b where
+ forall a. H [a] (Maybe b) = Double
+
+type family J a
+type instance forall a. J (a, b) = Bool
+
+data family K a
+data instance forall a. K (a, b) = K4 Bool
+
+data family L a
+newtype instance forall a. L (a, b) = L4 { unL4 :: Bool }
+
+class C a where
+ type CT a b
+ data CD a b
+instance C Int where
+ type forall a. CT [a] (Maybe b) = Bool
+ data forall a. CD [a] (Maybe b) = CD4 Bool
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.stderr
new file mode 100644
index 0000000000..92e0b1df64
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.stderr
@@ -0,0 +1,17 @@
+
+ExplicitForAllFams3.hs:7:28: error: Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:10:33: error:
+ Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:13:33: error:
+ Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:16:36: error:
+ Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:22:34: error:
+ Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:23:34: error:
+ Not in scope: type variable ‘b’
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.hs b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.hs
new file mode 100644
index 0000000000..f99e884161
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams4a where
+
+type family H a b where
+ forall a b. H [a] (a,a) = Float
+ forall b. H _ _ = Maybe b
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr
new file mode 100644
index 0000000000..ecbd7d9e79
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr
@@ -0,0 +1,8 @@
+
+ExplicitForAllFams4a.hs:7:12: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the type family declaration for ‘H’
+
+ExplicitForAllFams4a.hs:8:10: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the type family declaration for ‘H’
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs
new file mode 100644
index 0000000000..cb5665401b
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams4 where
+
+type family J a
+type instance forall a b. J [a] = Float
+type instance forall b. J _ = Maybe b
+
+data family K a
+data instance forall a b. K (a, Bool) = K5 Float
+data instance forall b. K _ = K6 (Maybe b)
+
+data family L a
+newtype instance forall a b. L (a, Bool) = L5 { unL5 :: Float }
+newtype instance forall b. L _ = L6 { unL56:: Maybe b }
+
+class C a where
+ type CT a b
+ data CD a b
+
+instance C Int where
+ type forall a b. CT [a] (a,a) = Float
+ type forall b. CT _ _ = Maybe b
+ data forall a b. CD [a] (a,a) = CD5 Float
+ data forall b. CD _ _ = CD6 (Maybe b)
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr
new file mode 100644
index 0000000000..0861a8a756
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr
@@ -0,0 +1,44 @@
+
+ExplicitForAllFams4b.hs:7:24: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the type instance declaration for ‘J’
+
+ExplicitForAllFams4b.hs:8:22: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the type instance declaration for ‘J’
+
+ExplicitForAllFams4b.hs:11:24: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the data instance declaration for ‘K’
+
+ExplicitForAllFams4b.hs:12:22: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the data instance declaration for ‘K’
+
+ExplicitForAllFams4b.hs:15:27: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the newtype instance declaration for ‘L’
+
+ExplicitForAllFams4b.hs:16:25: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the newtype instance declaration for ‘L’
+
+ExplicitForAllFams4b.hs:23:17: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the type instance declaration for ‘CT’
+ In the instance declaration for ‘C Int’
+
+ExplicitForAllFams4b.hs:24:15: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the type instance declaration for ‘CT’
+ In the instance declaration for ‘C Int’
+
+ExplicitForAllFams4b.hs:25:17: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the data instance declaration for ‘CD’
+ In the instance declaration for ‘C Int’
+
+ExplicitForAllFams4b.hs:26:15: error:
+ • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+ • In the data instance declaration for ‘CD’
+ In the instance declaration for ‘C Int’
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index 11e9d0a65d..12fa999a9f 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -35,6 +35,10 @@ test('OverIndirectThisMod', [], multimod_compile_fail, ['OverIndirectThisModD',
test('SkolemOccursLoop', expect_fail, compile_fail, [''])
+test('ExplicitForAllFams3', normal, compile_fail, [''])
+test('ExplicitForAllFams4a', normal, compile_fail, [''])
+test('ExplicitForAllFams4b', normal, compile_fail, [''])
+
test('T2334A', normal, compile_fail, [''])
test('T1900', normal, compile_fail, [''])
test('T2157', normal, compile_fail, [''])
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index edc66e0a2d..4648baa1f1 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -78,6 +78,7 @@
({ DumpParsedAst.hs:8:3-8 }
(Unqual
{OccName: Length}))
+ (Nothing)
[({ DumpParsedAst.hs:8:10-17 }
(HsParTy
(NoExt)
@@ -140,6 +141,7 @@
({ DumpParsedAst.hs:9:3-8 }
(Unqual
{OccName: Length}))
+ (Nothing)
[({ DumpParsedAst.hs:9:10-12 }
(HsExplicitListTy
(NoExt)
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index f20c450a9a..5c1a03e091 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -131,6 +131,7 @@
(NoExt)
({ DumpRenamedAst.hs:11:3-8 }
{Name: DumpRenamedAst.Length})
+ (Nothing)
[({ DumpRenamedAst.hs:11:10-17 }
(HsParTy
(NoExt)
@@ -186,6 +187,7 @@
(NoExt)
({ DumpRenamedAst.hs:12:3-8 }
{Name: DumpRenamedAst.Length})
+ (Nothing)
[({ DumpRenamedAst.hs:12:10-12 }
(HsExplicitListTy
(NoExt)
@@ -289,6 +291,7 @@
(NoExt)
({ DumpRenamedAst.hs:17:18-20 }
{Name: DumpRenamedAst.Nat})
+ (Nothing)
[({ DumpRenamedAst.hs:17:22-37 }
(HsParTy
(NoExt)
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index 4aee57db37..71a54b085a 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -37,6 +37,7 @@
({ KindSigs.hs:12:3-5 }
(Unqual
{OccName: Foo}))
+ (Nothing)
[({ KindSigs.hs:12:7 }
(HsTyVar
(NoExt)
diff --git a/testsuite/tests/rename/should_compile/ExplicitForAllRules1.hs b/testsuite/tests/rename/should_compile/ExplicitForAllRules1.hs
new file mode 100644
index 0000000000..7862468d17
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExplicitForAllRules1.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeApplications #-}
+
+module ExplicitForAllRules1 where
+
+import Data.Proxy
+import Data.Kind
+
+-- From Proposal 0007 (w/ fix to "example")
+
+{-# RULES
+"example" forall a b. forall. map @a @b f = f
+"example2" forall a. forall (x :: a). id x = x
+ #-}
+
+{-# NOINLINE f #-}
+f :: a -> b
+f = undefined
+
+-- More tests
+
+{-# RULES
+"example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = ()
+"example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @()
+"example5" forall (a :: Type). forall. h @a = id @a
+"example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x
+ #-}
+
+{-# NOINLINE g #-}
+g :: a -> b -> ()
+g _ _ = ()
+
+{-# NOINLINE h #-}
+h :: a -> a
+h x = x
+
+-- Should NOT have a parse error :(
+{-# RULES "example6" forall a forall. g a forall = () #-}
+
+-- Should generate a warning
+{-# RULES "example7" forall a b. forall (x :: a). id x = x #-}
diff --git a/testsuite/tests/rename/should_compile/ExplicitForAllRules1.stderr b/testsuite/tests/rename/should_compile/ExplicitForAllRules1.stderr
new file mode 100644
index 0000000000..54a32adafd
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExplicitForAllRules1.stderr
@@ -0,0 +1,4 @@
+
+ExplicitForAllRules1.hs:45:31: warning: [-Wunused-foralls (in -Wextra)]
+ Unused quantified type variable ‘b’
+ in the rule "example7"
diff --git a/testsuite/tests/rename/should_compile/T2600.hs b/testsuite/tests/rename/should_compile/T2600.hs
new file mode 100644
index 0000000000..bdf483cace
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T2600.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+
+module T2600 where
+
+-- ** See trac #10595 for why we're okay with this generating warnings! **
+
+class T t where
+ to :: [a] -> t a
+ from :: t a -> [a]
+ tmap :: (a -> a) -> t a -> t a
+
+{-# RULES
+
+"myrule" forall t a. forall f x.
+ from (tmap f (to x :: t a)) = map f (from (to x :: t a))
+
+ #-}
diff --git a/testsuite/tests/rename/should_compile/T2600.stderr b/testsuite/tests/rename/should_compile/T2600.stderr
new file mode 100644
index 0000000000..91f594ff9e
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T2600.stderr
@@ -0,0 +1,10 @@
+
+T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)]
+ Rule "myrule" may never fire
+ because rule "Class op tmap" for ‘tmap’ might fire first
+ Probable fix: add phase [n] or [~n] to the competing rule
+
+T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)]
+ Rule "myrule" may never fire
+ because rule "Class op to" for ‘to’ might fire first
+ Probable fix: add phase [n] or [~n] to the competing rule \ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 3a90cbd667..a3f862f8a4 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -81,6 +81,10 @@ test('T2205', normal, compile, [''])
test('T2334', normal, compile, [''])
test('T2506', normal, compile, [''])
+
+test('ExplicitForAllRules1', normal, compile, ['-Wunused-foralls'])
+test('T2600', normal, compile, [''])
+
test('T2914', normal, compile, [''])
test('T3221', normal, compile, [''])
test('T3262', normal, compile, [''])
diff --git a/testsuite/tests/rename/should_fail/ExplicitForAllRules2.hs b/testsuite/tests/rename/should_fail/ExplicitForAllRules2.hs
new file mode 100644
index 0000000000..081b39bced
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/ExplicitForAllRules2.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeApplications #-}
+
+module ExplicitForAllRules2 where
+
+{-# RULES "new4" forall a. forall (x :: b). id @a (wk x) = (wk x) #-}
+{-# RULES "new5" forall a. forall (x :: a). id @a y = y #-}
+{-# RULES "new6" forall a. forall (x :: a). id @c x = x #-}
+
+{-# NOINLINE wk #-}
+wk :: forall b a. b -> a
+wk _ = error ""
diff --git a/testsuite/tests/rename/should_fail/ExplicitForAllRules2.stderr b/testsuite/tests/rename/should_fail/ExplicitForAllRules2.stderr
new file mode 100644
index 0000000000..909cc0ae20
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/ExplicitForAllRules2.stderr
@@ -0,0 +1,10 @@
+
+ExplicitForAllRules2.hs:6:41: error:
+ Not in scope: type variable ‘b’
+
+ExplicitForAllRules2.hs:7:11: error:
+ Rule "new5":
+ Forall'd variable ‘x’ does not appear on left hand side
+
+ExplicitForAllRules2.hs:8:49: error:
+ Not in scope: type variable ‘c’
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index db0db47ca9..6debe7b917 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -138,3 +138,5 @@ test('T15539', normal, compile_fail, [''])
test('T15487', normal, multimod_compile_fail, ['T15487','-v0'])
test('T15659', normal, compile_fail, [''])
test('T15607', normal, compile_fail, [''])
+
+test('ExplicitForAllRules2', normal, compile_fail, [''])
diff --git a/testsuite/tests/th/ClosedFam2TH.hs b/testsuite/tests/th/ClosedFam2TH.hs
index 0b25da9248..2a8b3b4ab6 100644
--- a/testsuite/tests/th/ClosedFam2TH.hs
+++ b/testsuite/tests/th/ClosedFam2TH.hs
@@ -11,10 +11,12 @@ $( return [ ClosedTypeFamilyD
, KindedTV (mkName "b") (VarT (mkName "k")) ]
( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k"))))
Nothing)
- [ TySynEqn [ (VarT (mkName "a"))
+ [ TySynEqn Nothing
+ [ (VarT (mkName "a"))
, (VarT (mkName "a")) ]
(ConT (mkName "Int"))
- , TySynEqn [ (VarT (mkName "a"))
+ , TySynEqn Nothing
+ [ (VarT (mkName "a"))
, (VarT (mkName "b")) ]
(ConT (mkName "Bool")) ] ])
diff --git a/testsuite/tests/th/T12503.hs b/testsuite/tests/th/T12503.hs
index 517c4ba156..eef302c429 100644
--- a/testsuite/tests/th/T12503.hs
+++ b/testsuite/tests/th/T12503.hs
@@ -21,7 +21,7 @@ data family T2 (a :: b)
data instance T2 b
class C2 a
-$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ [tyVar] _ _ _]
+$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ _ [tyVar] _ _ _]
<- reify ''T2
d <- instanceD (cxt [])
(conT ''C2 `appT` (conT tName `appT` return tyVar))
diff --git a/testsuite/tests/th/T12646.stderr b/testsuite/tests/th/T12646.stderr
index 647ccd6396..5b25cff89f 100644
--- a/testsuite/tests/th/T12646.stderr
+++ b/testsuite/tests/th/T12646.stderr
@@ -1,3 +1,4 @@
type family T12646.F (a_0 :: k_1) :: * where
- T12646.F (a_2 :: * -> *) = GHC.Types.Int
- T12646.F (a_3 :: k_4) = GHC.Types.Char
+ forall (a_2 :: * -> *). T12646.F (a_2 :: * -> *) = GHC.Types.Int
+ forall (k_3 :: *)
+ (a_4 :: k_3). T12646.F (a_4 :: k_3) = GHC.Types.Char
diff --git a/testsuite/tests/th/T13618.hs b/testsuite/tests/th/T13618.hs
index 487b5e4efc..1156aada39 100644
--- a/testsuite/tests/th/T13618.hs
+++ b/testsuite/tests/th/T13618.hs
@@ -15,11 +15,11 @@ $(return [])
main :: IO ()
main = print
$(do FamilyI (DataFamilyD _ _ _) insts <- reify ''DF
- lift $ all (\case DataInstD _ _ [AppT _ (VarT v1)] _
- [NormalC _ [(_, VarT v2)]] _
+ lift $ all (\case DataInstD _ _ _ [AppT _ (VarT v1)] _
+ [NormalC _ [(_, VarT v2)]] _
-> v1 == v2
- NewtypeInstD _ _ [AppT _ (VarT v1)] _
- (NormalC _ [(_, VarT v2)]) _
+ NewtypeInstD _ _ _ [AppT _ (VarT v1)] _
+ (NormalC _ [(_, VarT v2)]) _
-> v1 == v2
_ -> error "Not a data or newtype instance")
insts)
diff --git a/testsuite/tests/th/T5886a.hs b/testsuite/tests/th/T5886a.hs
index 33b4d0e1e2..5756fcc513 100644
--- a/testsuite/tests/th/T5886a.hs
+++ b/testsuite/tests/th/T5886a.hs
@@ -11,5 +11,5 @@ class C α where
type AT α ∷ Type
bang ∷ DecsQ
-bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int))
- [TySynInstD ''AT (TySynEqn [ConT ''Int] (ConT ''Int))]]
+bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int))
+ [TySynInstD ''AT (TySynEqn Nothing [ConT ''Int] (ConT ''Int))]]
diff --git a/testsuite/tests/th/T6018th.hs b/testsuite/tests/th/T6018th.hs
index 442e4ab5dd..6b7b67d5a9 100644
--- a/testsuite/tests/th/T6018th.hs
+++ b/testsuite/tests/th/T6018th.hs
@@ -20,17 +20,20 @@ $( return
[(mkName "a"), (mkName "b"), (mkName "c") ]))
, TySynInstD
(mkName "F")
- (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ (TySynEqn Nothing
+ [ ConT (mkName "Int"), ConT (mkName "Char")
, ConT (mkName "Bool")]
( ConT (mkName "Bool")))
, TySynInstD
(mkName "F")
- (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool")
+ (TySynEqn Nothing
+ [ ConT (mkName "Char"), ConT (mkName "Bool")
, ConT (mkName "Int")]
( ConT (mkName "Int")))
, TySynInstD
(mkName "F")
- (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+ (TySynEqn Nothing
+ [ ConT (mkName "Bool"), ConT (mkName "Int")
, ConT (mkName "Char")]
( ConT (mkName "Char")))
] )
@@ -48,7 +51,8 @@ $( return
(Just $ InjectivityAnn (mkName "r") [mkName "a"]))
, TySynInstD
(mkName "J")
- (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ]
+ (TySynEqn Nothing
+ [ ConT (mkName "Int"), VarT (mkName "b") ]
( ConT (mkName "Int")))
] )
@@ -66,13 +70,16 @@ $( return
, KindedTV (mkName "c") StarT ]
(TyVarSig (PlainTV (mkName "r")))
(Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]))
- [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ [ TySynEqn Nothing
+ [ ConT (mkName "Int"), ConT (mkName "Char")
, ConT (mkName "Bool")]
( ConT (mkName "Bool"))
- , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ , TySynEqn Nothing
+ [ ConT (mkName "Int"), ConT (mkName "Char")
, ConT (mkName "Int")]
( ConT (mkName "Bool"))
- , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+ , TySynEqn Nothing
+ [ ConT (mkName "Bool"), ConT (mkName "Int")
, ConT (mkName "Int")]
( ConT (mkName "Int"))
]
@@ -103,17 +110,20 @@ $( return
[(mkName "a"), (mkName "b") ]))
, TySynInstD
(mkName "H")
- (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ (TySynEqn Nothing
+ [ ConT (mkName "Int"), ConT (mkName "Char")
, ConT (mkName "Bool")]
( ConT (mkName "Bool")))
, TySynInstD
(mkName "H")
- (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int")
+ (TySynEqn Nothing
+ [ ConT (mkName "Int"), ConT (mkName "Int")
, ConT (mkName "Int")]
( ConT (mkName "Bool")))
, TySynInstD
(mkName "H")
- (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+ (TySynEqn Nothing
+ [ ConT (mkName "Bool"), ConT (mkName "Int")
, ConT (mkName "Int")]
( ConT (mkName "Int")))
] )
diff --git a/testsuite/tests/th/T6018th.stderr b/testsuite/tests/th/T6018th.stderr
index 7193fb5948..9566b1acd5 100644
--- a/testsuite/tests/th/T6018th.stderr
+++ b/testsuite/tests/th/T6018th.stderr
@@ -1,5 +1,5 @@
-T6018th.hs:97:4:
+T6018th.hs:104:4:
Type family equations violate injectivity annotation:
- H Int Int Int = Bool -- Defined at T6018th.hs:97:4
- H Int Char Bool = Bool -- Defined at T6018th.hs:97:4
+ H Int Int Int = Bool -- Defined at T6018th.hs:104:4
+ H Int Char Bool = Bool -- Defined at T6018th.hs:104:4
diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs
index 84fa23e69f..8f686fe206 100644
--- a/testsuite/tests/th/T7532a.hs
+++ b/testsuite/tests/th/T7532a.hs
@@ -11,5 +11,5 @@ class C a where
bang' :: DecsQ
bang' = return [
InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
- DataInstD [] ''D [ConT ''Int] Nothing [
+ DataInstD [] ''D Nothing [ConT ''Int] Nothing [
NormalC (mkName "T") []] []]]
diff --git a/testsuite/tests/th/T8884.stderr b/testsuite/tests/th/T8884.stderr
index 022776ea7f..3226507172 100644
--- a/testsuite/tests/th/T8884.stderr
+++ b/testsuite/tests/th/T8884.stderr
@@ -1,4 +1,5 @@
type family T8884.Foo (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0 where
- T8884.Foo (x_3 :: k_4) = x_3
+ forall (k_3 :: *) (x_4 :: k_3). T8884.Foo (x_4 :: k_3) = x_4
type family T8884.Baz (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0
-type instance T8884.Baz (x_0 :: k_1) = x_0
+type instance forall (k_0 :: *)
+ (x_1 :: k_0). T8884.Baz (x_1 :: k_0) = x_1
diff --git a/testsuite/tests/th/T8953.stderr b/testsuite/tests/th/T8953.stderr
index 3dad41244b..d87acef442 100644
--- a/testsuite/tests/th/T8953.stderr
+++ b/testsuite/tests/th/T8953.stderr
@@ -1,6 +1,7 @@
type family T8953.Poly (a_0 :: k_1) :: *
-type instance T8953.Poly (x_2 :: GHC.Types.Bool) = GHC.Types.Int
-type instance T8953.Poly (x_3 :: GHC.Maybe.Maybe k_4) = GHC.Types.Double
+type instance forall (x_2 :: GHC.Types.Bool). T8953.Poly (x_2 :: GHC.Types.Bool) = GHC.Types.Int
+type instance forall (k_3 :: *)
+ (x_4 :: GHC.Maybe.Maybe k_3). T8953.Poly (x_4 :: GHC.Maybe.Maybe k_3) = GHC.Types.Double
type family T8953.Silly :: k_0 -> *
type instance T8953.Silly = (Data.Proxy.Proxy :: * -> *)
type instance T8953.Silly = (Data.Proxy.Proxy :: (* -> *) -> *)
@@ -15,5 +16,6 @@ type instance T8953.F GHC.Types.Char = T8953.G (T8953.T1 :: * ->
(* -> *) -> *)
GHC.Types.Bool
type family T8953.G (a_0 :: k_1) :: k_1
-type instance T8953.G (T8953.T1 :: k1_2 ->
- k2_3 -> *) = (T8953.T2 :: k1_2 -> k2_3 -> *)
+type instance forall (k1_2 :: *)
+ (k2_3 :: *). T8953.G (T8953.T1 :: k1_2 ->
+ k2_3 -> *) = (T8953.T2 :: k1_2 -> k2_3 -> *)
diff --git a/testsuite/tests/th/TH_ExplicitForAllRules.hs b/testsuite/tests/th/TH_ExplicitForAllRules.hs
new file mode 100644
index 0000000000..f5bd519db8
--- /dev/null
+++ b/testsuite/tests/th/TH_ExplicitForAllRules.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell, ExplicitForAll #-}
+
+module Main where
+
+import TH_ExplicitForAllRules_a
+
+$(decls)
+
+main = hsToTh
diff --git a/testsuite/tests/th/TH_ExplicitForAllRules.stdout b/testsuite/tests/th/TH_ExplicitForAllRules.stdout
new file mode 100644
index 0000000000..635fce750e
--- /dev/null
+++ b/testsuite/tests/th/TH_ExplicitForAllRules.stdout
@@ -0,0 +1,3 @@
+{-# RULES "example"
+ forall a_0 . forall (x_1 :: a_0) . GHC.Base.id x_1
+ = x_1 #-} \ No newline at end of file
diff --git a/testsuite/tests/th/TH_ExplicitForAllRules_a.hs b/testsuite/tests/th/TH_ExplicitForAllRules_a.hs
new file mode 100644
index 0000000000..e428035492
--- /dev/null
+++ b/testsuite/tests/th/TH_ExplicitForAllRules_a.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitForAll #-}
+module TH_ExplicitForAllRules_a (decls, hsToTh) where
+
+import Language.Haskell.TH
+
+decls = [d| {-# RULES "example" forall a. forall (x :: a). id x = x #-} |]
+
+hsToTh = do
+ decls' <- runQ decls
+ mapM (print . ppr) decls'
diff --git a/testsuite/tests/th/TH_reifyExplicitForAllFams.hs b/testsuite/tests/th/TH_reifyExplicitForAllFams.hs
new file mode 100644
index 0000000000..60a6d4563f
--- /dev/null
+++ b/testsuite/tests/th/TH_reifyExplicitForAllFams.hs
@@ -0,0 +1,35 @@
+-- test reification of explicit foralls in type families
+
+{-# LANGUAGE TypeFamilies, ExplicitForAll #-}
+module TH_reifyExplicitForAllFams where
+
+import System.IO
+import Language.Haskell.TH
+import Text.PrettyPrint.HughesPJ
+
+import Data.Proxy
+import Data.Kind
+
+$([d| data family F a
+ data instance forall a. F (Maybe a) = MkF a |])
+
+$([d| class C a where
+ type G a b
+ instance forall a. C [a] where
+ type forall b. G [a] b = Proxy b |])
+
+$([d| type family H a b where
+ forall x y. H [x] (Proxy y) = Either x y
+ forall z. H z z = Maybe z |])
+
+$(return [])
+
+test :: ()
+test = $(let
+ display :: Name -> Q ()
+ display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
+ in do { display ''F
+ ; display ''C
+ ; display ''G
+ ; display ''H
+ ; [| () |] })
diff --git a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
new file mode 100644
index 0000000000..6205547873
--- /dev/null
+++ b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
@@ -0,0 +1,16 @@
+data family TH_reifyExplicitForAllFams.F (a_0 :: *) :: *
+data instance forall (a_1 :: *). TH_reifyExplicitForAllFams.F (GHC.Maybe.Maybe a_1)
+ = TH_reifyExplicitForAllFams.MkF a_1
+class TH_reifyExplicitForAllFams.C (a_0 :: *)
+ where type TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
+instance TH_reifyExplicitForAllFams.C ([a_2])
+type family TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
+type instance forall (a_2 :: *)
+ (b_3 :: *). TH_reifyExplicitForAllFams.G ([a_2])
+ b_3 = Data.Proxy.Proxy b_3
+type family TH_reifyExplicitForAllFams.H (a_0 :: *) (b_1 :: *) :: * where
+ forall (x_2 :: *) (y_3 :: *). TH_reifyExplicitForAllFams.H ([x_2])
+ (Data.Proxy.Proxy y_3) = Data.Either.Either x_2
+ y_3
+ forall (z_4 :: *). TH_reifyExplicitForAllFams.H z_4
+ z_4 = GHC.Maybe.Maybe z_4 \ No newline at end of file
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 75ec5dbca6..50154a4fea 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -76,6 +76,10 @@ test('TH_reifyMkName', normal, compile, ['-v0'])
test('TH_reifyInstances', normal, compile, ['-v0'])
+test('TH_reifyExplicitForAllFams', normal, compile, ['-v0'])
+test('TH_ExplicitForAllRules', normal, multimod_compile_and_run,
+ ['TH_ExplicitForAllRules.hs', '-v0 ' + config.ghc_th_way_flags])
+
test('TH_spliceDecl1', normal, compile, ['-v0'])
test('TH_spliceDecl2', normal, compile, ['-v0'])
test('TH_spliceDecl3', [], multimod_compile,
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index 6f5564d8ea..e774b80726 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -306,7 +306,7 @@ boundThings modname lbinding =
LitPat _ _ -> tl
NPat {} -> tl -- form of literal pattern?
NPlusKPat _ id _ _ _ _ -> thing id : tl
- SigPat _ p -> patThings p tl
+ SigPat _ p _ -> patThings p tl
_ -> error "boundThings"
conArgs (PrefixCon ps) tl = foldr patThings tl ps
conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
diff --git a/utils/haddock b/utils/haddock
-Subproject b5372b7d86e3058b419076641dd3048258c4ddf
+Subproject f3455051b59c99d26e0cf040be45f5916463ae5