diff options
| author | Matthew Yacavone <matthew@yacavone.net> | 2018-10-27 14:01:42 -0400 |
|---|---|---|
| committer | Richard Eisenberg <rae@cs.brynmawr.edu> | 2018-10-27 14:54:56 -0400 |
| commit | 512eeb9bb9a81e915bfab25ca16bc87c62252064 (patch) | |
| tree | 803e752c6907fdfc89a5f71e6bfda04d7ef86bea /compiler | |
| parent | 23956b2ada690c78a134fe6d149940c777c7efcc (diff) | |
| download | haskell-512eeb9bb9a81e915bfab25ca16bc87c62252064.tar.gz | |
More explicit foralls (GHC Proposal 0007)
Allow the user to explicitly bind type/kind variables in type and data
family instances (including associated instances), closed type family
equations, and RULES pragmas. Follows the specification of GHC
Proposal 0007, also fixes #2600. Advised by Richard Eisenberg.
This modifies the Template Haskell AST -- old code may break!
Other Changes:
- convert HsRule to a record
- make rnHsSigWcType more general
- add repMaybe to DsMeta
Includes submodule update for Haddock.
Test Plan: validate
Reviewers: goldfire, bgamari, alanz
Subscribers: simonpj, RyanGlScott, goldfire, rwbarton,
thomie, mpickering, carter
GHC Trac Issues: #2600, #14268
Differential Revision: https://phabricator.haskell.org/D4894
Diffstat (limited to 'compiler')
38 files changed, 764 insertions, 429 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. |