Commit 512eeb9b authored by mayac's avatar mayac Committed by Richard Eisenberg

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
parent 23956b2a
......@@ -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
......
......@@ -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)
......
......@@ -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]
......
......@@ -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)
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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'}
......
......@@ -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
......
......@@ -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
......
......@@ -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)
)
......@@ -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
......@@ -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)