diff options
author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2021-04-01 21:51:17 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-05-23 18:53:50 -0400 |
commit | f8c6fce4a09762adea6009540e523c2b984b2978 (patch) | |
tree | fb0898eadf884f4320e5a05f783f6308663350e9 /compiler | |
parent | d82d38239f232c3970a8641bb6d47d436e3cbc11 (diff) | |
download | haskell-f8c6fce4a09762adea6009540e523c2b984b2978.tar.gz |
HsToken for HsPar, ParPat, HsCmdPar (#19523)
This patch is a first step towards a simpler design for exact printing.
Diffstat (limited to 'compiler')
30 files changed, 161 insertions, 129 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index a25f90d0b0..89292b59c3 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -278,7 +278,7 @@ type instance XNegApp GhcPs = EpAnn [AddEpAnn] type instance XNegApp GhcRn = NoExtField type instance XNegApp GhcTc = NoExtField -type instance XPar (GhcPass _) = EpAnn AnnParen +type instance XPar (GhcPass _) = EpAnnCO type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn] type instance XExplicitTuple GhcRn = NoExtField @@ -496,7 +496,7 @@ ppr_expr (HsIPVar _ v) = ppr v ppr_expr (HsOverLabel _ l) = char '#' <> ppr l ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit -ppr_expr (HsPar _ e) = parens (ppr_lexpr e) +ppr_expr (HsPar _ _ e _) = parens (ppr_lexpr e) ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] @@ -810,19 +810,23 @@ hsExprNeedsParens prec = go go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a +-- | Parenthesize an expression without token information +gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id) +gHsPar e = HsPar noAnn noHsTok e noHsTok + -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) parenthesizeHsExpr p le@(L loc e) - | hsExprNeedsParens p e = L loc (HsPar noAnn le) + | hsExprNeedsParens p e = L loc (gHsPar le) | otherwise = le stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e +stripParensLHsExpr (L _ (HsPar _ _ e _)) = stripParensLHsExpr e stripParensLHsExpr e = e stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p) -stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e +stripParensHsExpr (HsPar _ _ (L _ e) _) = stripParensHsExpr e stripParensHsExpr e = e isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool @@ -1044,7 +1048,7 @@ type instance XCmdArrForm GhcTc = NoExtField type instance XCmdApp (GhcPass _) = EpAnnCO type instance XCmdLam (GhcPass _) = NoExtField -type instance XCmdPar (GhcPass _) = EpAnn AnnParen +type instance XCmdPar (GhcPass _) = EpAnnCO type instance XCmdCase GhcPs = EpAnn EpAnnHsCase type instance XCmdCase GhcRn = NoExtField @@ -1116,7 +1120,7 @@ ppr_lcmd c = ppr_cmd (unLoc c) ppr_cmd :: forall p. (OutputableBndrId p ) => HsCmd (GhcPass p) -> SDoc -ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) +ppr_cmd (HsCmdPar _ _ c _) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp _ c e) = let (fun, args) = collect_args c [e] in diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index e28bcddbf1..0a43cb8aa6 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -229,3 +229,8 @@ pprIfRn pp = case ghcPass @p of GhcRn -> pp pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc pprIfTc pp = case ghcPass @p of GhcTc -> pp _ -> empty + +type instance Anno (HsToken tok) = EpAnnCO + +noHsTok :: GenLocated (EpAnn a) (HsToken tok) +noHsTok = L noAnn HsTok diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 239c57418b..68d76909a2 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -39,7 +39,7 @@ module GHC.Hs.Pat ( isSimplePat, looksLazyPatBind, isBangedLPat, - patNeedsParens, parenthesizePat, + gParPat, patNeedsParens, parenthesizePat, isIrrefutableHsPat, collectEvVarsPat, collectEvVarsPats, @@ -103,7 +103,7 @@ type instance XAsPat GhcPs = EpAnn [AddEpAnn] -- For '@' type instance XAsPat GhcRn = NoExtField type instance XAsPat GhcTc = NoExtField -type instance XParPat (GhcPass _) = EpAnn AnnParen +type instance XParPat (GhcPass _) = EpAnnCO type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!' type instance XBangPat GhcRn = NoExtField @@ -285,7 +285,7 @@ pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] -pprPat (ParPat _ pat) = parens (ppr pat) +pprPat (ParPat _ _ pat _) = parens (ppr pat) pprPat (LitPat _ s) = ppr s pprPat (NPat _ l Nothing _) = ppr l pprPat (NPat _ l (Just _) _) = char '-' <> ppr l @@ -420,7 +420,7 @@ isBangedLPat :: LPat (GhcPass p) -> Bool isBangedLPat = isBangedPat . unLoc isBangedPat :: Pat (GhcPass p) -> Bool -isBangedPat (ParPat _ p) = isBangedLPat p +isBangedPat (ParPat _ _ p _) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _ = False @@ -441,8 +441,8 @@ looksLazyLPat :: LPat (GhcPass p) -> Bool looksLazyLPat = looksLazyPat . unLoc looksLazyPat :: Pat (GhcPass p) -> Bool -looksLazyPat (ParPat _ p) = looksLazyLPat p -looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (ParPat _ _ p _) = looksLazyLPat p +looksLazyPat (AsPat _ _ p) = looksLazyLPat p looksLazyPat (BangPat {}) = False looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False @@ -508,7 +508,7 @@ isIrrefutableHsPat' is_strict = goL = isIrrefutableHsPat' False p' | otherwise = True go (BangPat _ pat) = goL pat - go (ParPat _ pat) = goL pat + go (ParPat _ _ pat _) = goL pat go (AsPat _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat @@ -553,7 +553,7 @@ isIrrefutableHsPat' is_strict = goL -- - x (variable) isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) isSimplePat p = case unLoc p of - ParPat _ x -> isSimplePat x + ParPat _ _ x _ -> isSimplePat x SigPat _ x _ -> isSimplePat x LazyPat _ x -> isSimplePat x BangPat _ x -> isSimplePat x @@ -628,6 +628,11 @@ conPatNeedsParens p = go go (InfixCon {}) = p >= opPrec -- type args should be empty in this case go (RecCon {}) = False + +-- | Parenthesize a pattern without token information +gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass) +gParPat p = ParPat noAnn noHsTok p noHsTok + -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: IsPass p @@ -635,7 +640,7 @@ parenthesizePat :: IsPass p -> LPat (GhcPass p) -> LPat (GhcPass p) parenthesizePat p lpat@(L loc pat) - | patNeedsParens p pat = L loc (ParPat noAnn lpat) + | patNeedsParens p pat = L loc (gParPat lpat) | otherwise = lpat {- @@ -654,7 +659,7 @@ collectEvVarsPat pat = case pat of LazyPat _ p -> collectEvVarsLPat p AsPat _ _ p -> collectEvVarsLPat p - ParPat _ p -> collectEvVarsLPat p + ParPat _ _ p _ -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 4f9e5c83bc..5c6a53a8a7 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -168,7 +168,7 @@ just attach 'noSrcSpan' to everything. -- | @e => (e)@ mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = L (getLoc e) (HsPar noAnn e) +mkHsPar e = L (getLoc e) (gHsPar e) mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, @@ -284,17 +284,13 @@ nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs -- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them -- So @f x@ becomes @(f x)@, but @3@ stays as @3@. mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsPar le@(L loc e) - | hsExprNeedsParens appPrec e = L loc (HsPar noAnn le) - | otherwise = le +mkLHsPar = parenthesizeHsExpr appPrec mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) -mkParPat lp@(L loc p) - | patNeedsParens appPrec p = L loc (ParPat noAnn lp) - | otherwise = lp +mkParPat = parenthesizePat appPrec nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -nlParPat p = noLocA (ParPat noAnn p) +nlParPat p = noLocA (gParPat p) ------------------------------- -- These are the bits of syntax that contain rebindable names @@ -594,7 +590,7 @@ nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs -- AZ:Is this used? nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match]))) -nlHsPar e = noLocA (HsPar noAnn e) +nlHsPar e = noLocA (gHsPar e) -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is False. (#12080) @@ -795,7 +791,7 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrap co_fn (XExpr (WrapExpr (HsWrap co_fn' e))) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn (HsPar x (L l e)) = HsPar x (L l (mkHsWrap co_fn e)) +mkHsWrap co_fn (HsPar x lpar (L l e) rpar) = HsPar x lpar (L l (mkHsWrap co_fn e)) rpar mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e) mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b @@ -925,13 +921,8 @@ mkMatch :: forall p. IsPass p mkMatch ctxt pats expr binds = noLocA (Match { m_ext = noAnn , m_ctxt = ctxt - , m_pats = map paren pats + , m_pats = map mkParPat pats , m_grhss = GRHSs noExtField (unguardedRHS noAnn noSrcSpan expr) binds }) - where - paren :: LPat (GhcPass p) -> LPat (GhcPass p) - paren lp@(L l p) - | patNeedsParens appPrec p = L l (ParPat noAnn lp) - | otherwise = lp {- ************************************************************************ @@ -1209,7 +1200,7 @@ collect_pat flag pat bndrs = case pat of BangPat _ pat -> collect_lpat flag pat bndrs AsPat _ a pat -> unXRec @p a : collect_lpat flag pat bndrs ViewPat _ _ pat -> collect_lpat flag pat bndrs - ParPat _ pat -> collect_lpat flag pat bndrs + ParPat _ _ pat _ -> collect_lpat flag pat bndrs ListPat _ pats -> foldr (collect_lpat flag) bndrs pats TuplePat _ pats _ -> foldr (collect_lpat flag) bndrs pats SumPat _ pat _ _ -> collect_lpat flag pat bndrs @@ -1584,7 +1575,7 @@ lPatImplicits = hs_lpat hs_pat (BangPat _ pat) = hs_lpat pat hs_pat (AsPat _ _ pat) = hs_lpat pat hs_pat (ViewPat _ _ pat) = hs_lpat pat - hs_pat (ParPat _ pat) = hs_lpat pat + hs_pat (ParPat _ _ pat _) = hs_lpat pat hs_pat (ListPat _ pats) = hs_lpats pats hs_pat (TuplePat _ pats _) = hs_lpats pats diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 0f7f261341..9183a4f8ed 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -447,7 +447,7 @@ dsCmd ids local_vars stack_ty res_ty env_ids = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids -dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ _ cmd _) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids -- D, xs |- e :: Bool diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index fbb14ce28f..d876ad39f4 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -543,8 +543,9 @@ addTickHsExpr (NegApp x e neg) = liftM2 (NegApp x) (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar x e) = - liftM (HsPar x) (addTickLHsExprEvalInner e) +addTickHsExpr (HsPar x lpar e rpar) = do + e' <- addTickLHsExprEvalInner e + return (HsPar x lpar e' rpar) addTickHsExpr (SectionL x e1 e2) = liftM2 (SectionL x) (addTickLHsExpr e1) @@ -869,7 +870,9 @@ addTickHsCmd (OpApp e1 c2 fix c3) = (return fix) (addTickLHsCmd c3) -} -addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) +addTickHsCmd (HsCmdPar x lpar e rpar) = do + e' <- addTickLHsCmd e + return (HsCmdPar x lpar e' rpar) addTickHsCmd (HsCmdCase x e mgs) = liftM2 (HsCmdCase x) (addTickLHsExpr e) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index e89ab4868b..0735ed9000 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -270,7 +270,7 @@ dsExpr (HsRecSel _ (FieldOcc id _)) = dsHsVar id dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref -- See Note [Holes] in GHC.Tc.Types.Constraint -dsExpr (HsPar _ e) = dsLExpr e +dsExpr (HsPar _ _ e _) = dsLExpr e dsExpr (ExprWithTySig _ e _) = dsLExpr e dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" @@ -1235,7 +1235,7 @@ dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr dsHsWrapped orig_hs_expr = go idHsWrapper orig_hs_expr where - go wrap (HsPar _ (L _ hs_e)) + go wrap (HsPar _ _ (L _ hs_e) _) = go wrap hs_e go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e))) = go (wrap1 <.> wrap2) hs_e diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index f8ba578775..33ffc1e998 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -421,7 +421,7 @@ tidy1 :: Id -- The Id being scrutinised -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) +tidy1 v o (ParPat _ _ pat _) = tidy1 v o (unLoc pat) tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p @@ -517,7 +517,7 @@ tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p +tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p -- Push the bang-pattern inwards, in the hope that @@ -1052,8 +1052,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar _ (L _ e)) e' = exp e e' - exp e (HsPar _ (L _ e')) = exp e e' + exp (HsPar _ _ (L _ e) _) e' = exp e e' + exp e (HsPar _ _ (L _ e') _) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) = diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 245b289ffd..b2f7043f45 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -447,7 +447,7 @@ getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. getLHsIntegralLit (L _ e) = go e where - go (HsPar _ e) = getLHsIntegralLit e + go (HsPar _ _ e _) = getLHsIntegralLit e go (HsOverLit _ over_lit) = getIntegralLit over_lit go (HsLit _ lit) = getSimpleIntegralLit lit @@ -478,7 +478,7 @@ getSimpleIntegralLit _ = Nothing -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char -getLHsCharLit (L _ (HsPar _ e)) = getLHsCharLit e +getLHsCharLit (L _ (HsPar _ _ e _)) = getLHsCharLit e getLHsCharLit (L _ (HsTick _ _ e)) = getLHsCharLit e getLHsCharLit (L _ (HsBinTick _ _ _ e)) = getLHsCharLit e getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index c835832702..fa32d391d2 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -108,7 +108,7 @@ desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd] desugarPat x pat = case pat of WildPat _ty -> pure [] VarPat _ y -> pure (mkPmLetVar (unLoc y) x) - ParPat _ p -> desugarLPat x p + ParPat _ _ p _ -> desugarLPat x p LazyPat _ _ -> pure [] -- like a wildcard BangPat _ p@(L l p') -> -- Add the bang in front of the list, because it will happen before any diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 21e70cf53c..3a70bc18d6 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1511,7 +1511,7 @@ repE (NegApp _ x _) = do a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a -repE (HsPar _ x) = repLE x +repE (HsPar _ _ x _) = repLE x repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } repE (HsCase _ e (MG { mg_alts = (L _ ms) })) @@ -2041,7 +2041,7 @@ repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat _ x p) = do { x' <- lookupNBinder x; p1 <- repLP p ; repPaspat x' p1 } -repP (ParPat _ p) = repLP p +repP (ParPat _ _ p _) = repLP p repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps) ; e' <- repE e diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index bc4787bbfb..49b21e2111 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -134,7 +134,7 @@ selectMatchVar :: Mult -> Pat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat) -selectMatchVar w (ParPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat) selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -- @@ -784,7 +784,7 @@ mkSelectorBinds ticks pat val_expr strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens -strip_bangs (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (L _ (ParPat _ _ p _)) = strip_bangs p strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp = lp @@ -792,7 +792,7 @@ is_flat_prod_lpat :: LPat GhcTc -> Bool is_flat_prod_lpat = is_flat_prod_pat . unLoc is_flat_prod_pat :: Pat GhcTc -> Bool -is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p +is_flat_prod_pat (ParPat _ _ p _) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPat { pat_con = L _ pcon , pat_args = ps}) @@ -807,7 +807,7 @@ is_triv_lpat = is_triv_pat . unLoc is_triv_pat :: Pat (GhcPass p) -> Bool is_triv_pat (VarPat {}) = True is_triv_pat (WildPat{}) = True -is_triv_pat (ParPat _ p) = is_triv_lpat p +is_triv_pat (ParPat _ _ p _) = is_triv_lpat p is_triv_pat _ = False @@ -1057,7 +1057,7 @@ decideBangHood dflags lpat where go lp@(L l p) = case p of - ParPat x p -> L l (ParPat x (go p)) + ParPat x lpar p rpar -> L l (ParPat x lpar (go p) rpar) LazyPat _ lp' -> lp' BangPat _ _ -> lp _ -> L l (BangPat noExtField lp) @@ -1089,5 +1089,5 @@ isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing +isTrueLHsExpr (L _ (HsPar _ _ e _)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index c9cbd4b723..94da21083f 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -962,7 +962,7 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where lname , toHie $ PS rsp scope pscope pat ] - ParPat _ pat -> + ParPat _ _ pat _ -> [ toHie $ PS rsp scope pscope pat ] BangPat _ pat -> @@ -1112,7 +1112,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where NegApp _ a _ -> [ toHie a ] - HsPar _ a -> + HsPar _ _ a _ -> [ toHie a ] SectionL _ a b -> @@ -1415,7 +1415,7 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where HsCmdLam _ mg -> [ toHie mg ] - HsCmdPar _ a -> + HsCmdPar _ _ a _ -> [ toHie a ] HsCmdCase _ expr alts -> diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 1848b6b1df..c89079ca70 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2880,7 +2880,7 @@ aexp2 :: { ECP } -- but the less cluttered version fell out of having texps. | '(' texp ')' { ECP $ unECP $2 >>= \ $2 -> - mkHsParPV (comb2 $1 $>) $2 (AnnParen AnnParens (glAA $1) (glAA $3)) } + mkHsParPV (comb2 $1 $>) (hsTok $1) $2 (hsTok $3) } | '(' tup_exprs ')' { ECP $ $2 >>= \ $2 -> mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2 @@ -4343,6 +4343,9 @@ listAsAnchor :: [LocatedAn t a] -> Anchor listAsAnchor [] = spanAsAnchor noSrcSpan listAsAnchor (L l _:_) = spanAsAnchor (locA l) +hsTok :: Located Token -> LHsToken tok GhcPs +hsTok (L l _) = L (EpAnn (Anchor (realSrcSpan l) UnchangedAnchor) NoEpAnns emptyComments) HsTok + -- ------------------------------------- addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 8cd5105e42..261967be85 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -1142,11 +1143,10 @@ checkAPat loc e0 = do , pat_args = InfixCon l r } - PatBuilderPar e an@(AnnParen pt o c) -> do - (L l p) <- checkLPat e - let aa = [AddEpAnn ai o, AddEpAnn ac c] - (ai,ac) = parenTypeKws pt - return (ParPat (EpAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an emptyComments) (L l p)) + PatBuilderPar lpar e rpar -> do + p <- checkLPat e + return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar) + _ -> patFail (locA loc) (ppr e0) placeHolderPunRhs :: DisambECP b => PV (LocatedA b) @@ -1287,7 +1287,7 @@ isFunLhs e = go e [] [] go (L _ (PatBuilderVar (L loc f))) es ann | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann - go (L l (PatBuilderPar e _an)) es@(_:_) ann + go (L l (PatBuilderPar _ e _)) es@(_:_) ann = go e es (ann ++ mkParensEpAnn (locA l)) go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ann | not (isRdrDataCon op) -- We have found the function! @@ -1460,7 +1460,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where AnnList -> PV (LocatedA b) -- | Disambiguate "( ... )" (parentheses) - mkHsParPV :: SrcSpan -> LocatedA b -> AnnParen -> PV (LocatedA b) + mkHsParPV :: SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b) -- | Disambiguate a variable "f" or a data constructor "MkF". mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) -- | Disambiguate a monomorphic literal @@ -1591,9 +1591,9 @@ instance DisambECP (HsCmd GhcPs) where cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts) mkHsDoPV l (Just m) _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l - mkHsParPV l c ann = do + mkHsParPV l lpar c rpar = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) ann cs) c) + return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar) mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a) mkHsOverLitPV (L l a) = cmdFail l (ppr a) @@ -1678,9 +1678,9 @@ instance DisambECP (HsExpr GhcPs) where mkHsDoPV l mod stmts anns = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts) - mkHsParPV l e ann = do + mkHsParPV l lpar e rpar = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) ann cs) e) + return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar) mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v) mkHsLitPV (L l a) = do cs <- getCommentsFor l @@ -1755,7 +1755,7 @@ instance DisambECP (PatBuilder GhcPs) where return $ L l (PatBuilderAppType p (mkHsPatSigType anns t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l mkHsDoPV l _ _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l - mkHsParPV l p an = return $ L (noAnnSrcSpan l) (PatBuilderPar p an) + mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do checkUnboxedStringLitPat lit diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs index b42d04f881..36abbe5125 100644 --- a/compiler/GHC/Parser/Types.hs +++ b/compiler/GHC/Parser/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} module GHC.Parser.Types ( SumOrTuple(..) @@ -52,7 +53,7 @@ pprSumOrTuple boxity = \case -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p = PatBuilderPat (Pat p) - | PatBuilderPar (LocatedA (PatBuilder p)) AnnParen + | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p) | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) @@ -62,7 +63,7 @@ data PatBuilder p instance Outputable (PatBuilder GhcPs) where ppr (PatBuilderPat p) = ppr p - ppr (PatBuilderPar (L _ p) _) = parens (ppr p) + ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p) ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2 diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index dce75ba1f2..564eabb601 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -333,17 +333,17 @@ rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice --------------------------------------------- -- Sections -- See Note [Parsing sections] in GHC.Parser -rnExpr (HsPar x (L loc (section@(SectionL {})))) +rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar) = do { (section', fvs) <- rnSection section - ; return (HsPar x (L loc section'), fvs) } + ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x (L loc (section@(SectionR {})))) +rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar) = do { (section', fvs) <- rnSection section - ; return (HsPar x (L loc section'), fvs) } + ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x e) +rnExpr (HsPar x lpar e rpar) = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar x e', fvs_e) } + ; return (HsPar x lpar e' rpar, fvs_e) } rnExpr expr@(SectionL {}) = do { addErr (sectionErr expr); rnSection expr } @@ -783,9 +783,9 @@ rnCmd (HsCmdLam _ matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches ; return (HsCmdLam noExtField matches', fvMatch) } -rnCmd (HsCmdPar x e) +rnCmd (HsCmdPar x lpar e rpar) = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar x e', fvs_e) } + ; return (HsCmdPar x lpar e' rpar, fvs_e) } rnCmd (HsCmdCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr @@ -835,7 +835,7 @@ methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName @@ -2145,7 +2145,7 @@ isStrictPattern lpat = VarPat{} -> False LazyPat{} -> False AsPat _ _ p -> isStrictPattern p - ParPat _ p -> isStrictPattern p + ParPat _ _ p _ -> isStrictPattern p ViewPat _ _ p -> isStrictPattern p SigPat _ p _ -> isStrictPattern p BangPat{} -> True @@ -2279,13 +2279,13 @@ needJoin _monad_names stmts = (True, stmts) isReturnApp :: MonadNames -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn, Bool) -isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr +isReturnApp monad_names (L _ (HsPar _ _ expr _)) = isReturnApp monad_names expr isReturnApp monad_names (L _ e) = case e of OpApp _ l op r | is_return l, is_dollar op -> Just (r, True) HsApp _ f arg | is_return f -> Just (arg, False) _otherwise -> Nothing where - is_var f (L _ (HsPar _ e)) = is_var f e + is_var f (L _ (HsPar _ _ 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 diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 5e0723d4cb..7a63d73fee 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -400,8 +400,9 @@ rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _ (WildPat _) = return (WildPat noExtField) -rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat - ; return (ParPat x pat') } +rnPatAndThen mk (ParPat x lpar pat rpar) = + do { pat' <- rnLPatAndThen mk pat + ; return (ParPat x lpar pat' rpar) } rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat ; return (LazyPat noExtField pat') } rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index d8bead6645..ab17333c0e 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -450,11 +450,11 @@ rnSpliceExpr splice runRnSplice UntypedExpSplice runMetaE ppr rn_splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsPar noAnn $ HsSpliceE noAnn - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedExpr <$> - lexpr3 - , fvs) + ; let e = HsSpliceE noAnn + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedExpr + <$> lexpr3 + ; return (gHsPar e, fvs) } {- Note [Running splices in the Renamer] @@ -694,12 +694,11 @@ rnSplicePat splice ; (pat, mod_finalizers) <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( Left $ ParPat noAnn $ ((SplicePat noExtField) - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedPat) `mapLoc` - pat - , emptyFVs - ) } + ; let p = SplicePat noExtField + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedPat + <$> pat + ; return (Left $ gParPat p, emptyFVs) } -- Wrap the result of the quasi-quoter in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 7ab31322c9..d6bf3ae129 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -145,9 +145,9 @@ tcCmd env (L loc cmd) res_ty ; return (L loc cmd') } tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTc) -tc_cmd env (HsCmdPar x cmd) res_ty +tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar x cmd') } + ; return (HsCmdPar x lpar cmd' rpar) } tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 94a36def48..992c00428e 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -221,9 +221,9 @@ tcExpr e@(HsLit x lit) res_ty = do { let lit_ty = hsLitType lit ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar x expr) res_ty +tcExpr (HsPar x lpar expr rpar) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar x expr') } + ; return (HsPar x lpar expr' rpar) } tcExpr (HsPragE x prag expr) res_ty = do { expr' <- tcMonoExpr expr res_ty diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index d018332e80..dd46120ea5 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -243,7 +243,7 @@ splitHsApps :: HsExpr GhcRn -- See Note [splitHsApps] splitHsApps e = go e (top_ctxt 0 e) [] where - top_ctxt n (HsPar _ fun) = top_lctxt n fun + top_ctxt n (HsPar _ _ fun _) = top_lctxt n fun top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun @@ -254,7 +254,7 @@ splitHsApps e = go e (top_ctxt 0 e) [] go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) - go (HsPar _ (L l fun)) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) + go (HsPar _ _ (L l fun) _) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args) go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args) go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args) @@ -292,7 +292,7 @@ rebuildHsApps fun ctxt (arg : args) EPrag ctxt' p -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args EWrap (EPar ctxt') - -> rebuildHsApps (HsPar noAnn lfun) ctxt' args + -> rebuildHsApps (gHsPar lfun) ctxt' args EWrap (EExpand orig) -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args EWrap (EHsWrap wrap) @@ -469,7 +469,7 @@ tcInferRecSelId (FieldOcc sel_name lbl) -- outermost constructor ignoring parentheses. obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) obviousSig (ExprWithTySig _ _ ty) = Just ty -obviousSig (HsPar _ p) = obviousSig (unLoc p) +obviousSig (HsPar _ _ p _) = obviousSig (unLoc p) obviousSig (HsPragE _ _ p) = obviousSig (unLoc p) obviousSig _ = Nothing diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 536baa278f..b401b4db60 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -363,9 +363,9 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } - ParPat x pat -> do + ParPat x lpar pat rpar -> do { (pat', res) <- tc_lpat pat_ty penv pat thing_inside - ; return (ParPat x pat', res) } + ; return (ParPat x lpar pat' rpar, res) } BangPat x pat -> do { (pat', res) <- tc_lpat pat_ty penv pat thing_inside diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index d659b4e8d9..5f511d539c 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -1023,7 +1023,7 @@ tcPatToExpr name args pat = go pat = return $ HsVar noExtField (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ pat) = fmap (HsPar noAnn) $ go pat + go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats ; return $ ExplicitList noExtField exprs } @@ -1201,7 +1201,7 @@ tcCollectEx pat = go pat go1 :: Pat GhcTc -> ([TyVar], [EvVar]) go1 (LazyPat _ p) = go p go1 (AsPat _ _ p) = go p - go1 (ParPat _ p) = go p + go1 (ParPat _ _ p _) = go p go1 (BangPat _ p) = go p go1 (ListPat _ ps) = mergeMany . map go $ ps go1 (TuplePat _ ps _) = mergeMany . map go $ ps diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 44ade07fcb..6a67a33e5b 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -509,7 +509,7 @@ exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e -exprCtOrigin (HsPar _ e) = lexprCtOrigin e +exprCtOrigin (HsPar _ _ e _) = lexprCtOrigin e exprCtOrigin (HsProjection _ _) = SectionOrigin exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index a11fe41f6a..9207e1805f 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -112,7 +112,7 @@ hsLPatType :: LPat GhcTc -> Type hsLPatType (L _ p) = hsPatType p hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ pat) = hsLPatType pat +hsPatType (ParPat _ _ pat _) = hsLPatType pat hsPatType (WildPat ty) = ty hsPatType (VarPat _ lvar) = idType (unLoc lvar) hsPatType (BangPat _ pat) = hsLPatType pat @@ -875,9 +875,9 @@ zonkExpr env (NegApp x expr op) new_expr <- zonkLExpr env' expr return (NegApp x new_expr new_op) -zonkExpr env (HsPar x e) +zonkExpr env (HsPar x lpar e rpar) = do new_e <- zonkLExpr env e - return (HsPar x new_e) + return (HsPar x lpar new_e rpar) zonkExpr env (SectionL x expr op) = do new_expr <- zonkLExpr env expr @@ -1081,9 +1081,9 @@ zonkCmd env (HsCmdLam x matches) = do new_matches <- zonkMatchGroup env zonkLCmd matches return (HsCmdLam x new_matches) -zonkCmd env (HsCmdPar x c) +zonkCmd env (HsCmdPar x lpar c rpar) = do new_c <- zonkLCmd env c - return (HsCmdPar x new_c) + return (HsCmdPar x lpar new_c rpar) zonkCmd env (HsCmdCase x expr ms) = do new_expr <- zonkLExpr env expr @@ -1412,9 +1412,9 @@ zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc) zonkPat env pat = wrapLocSndMA (zonk_pat env) pat zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat x p) +zonk_pat env (ParPat x lpar p rpar) = do { (env', p') <- zonkPat env p - ; return (env', ParPat x p') } + ; return (env', ParPat x lpar p' rpar) } zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToTypeX env ty diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index f2f9695109..7aa9b73eb2 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -933,7 +933,7 @@ cvtl e = wrapLA (cvt e) go cvt_lit mk_expr is_compound_lit = do l' <- cvt_lit l let e' = mk_expr l' - return $ if is_compound_lit l' then HsPar noAnn (noLocA e') else e' + return $ if is_compound_lit l' then gHsPar (noLocA e') else e' cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y ; return $ HsApp noComments (mkLHsPar x') (mkLHsPar y')} @@ -998,7 +998,7 @@ cvtl e = wrapLA (cvt e) ; y' <- cvtl y ; let px = parenthesizeHsExpr opPrec x' py = parenthesizeHsExpr opPrec y' - ; wrapParLA (HsPar noAnn) + ; wrapParLA gHsPar $ OpApp noAnn px s' py } -- Parenthesise both arguments and result, -- to ensure this operator application does @@ -1006,17 +1006,17 @@ cvtl e = wrapLA (cvt e) -- See Note [Operator association] cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ do { s' <- cvtl s; y' <- cvtl y - ; wrapParLA (HsPar noAnn) $ + ; wrapParLA gHsPar $ SectionR noComments s' y' } -- See Note [Sections in HsSyn] in GHC.Hs.Expr cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ do { x' <- cvtl x; s' <- cvtl s - ; wrapParLA (HsPar noAnn) $ + ; wrapParLA gHsPar $ SectionL noComments x' s' } cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ do { s' <- cvtl s - ; return $ HsPar noAnn s' } + ; return $ gHsPar s' } -- Can I indicate this is an infix thing? -- Note [Dropping constructors] @@ -1027,7 +1027,7 @@ cvtl e = wrapLA (cvt e) _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noAnn e' } + cvt (ParensE e) = do { e' <- cvtl e; return $ gHsPar e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtSigType t ; let pe = parenthesizeHsExpr sigPrec e' ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') } @@ -1208,7 +1208,7 @@ cvtMatch :: HsMatchContext GhcPs cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of - (L loc SigPat{}) -> L loc (ParPat noAnn p') -- #14875 + (L loc SigPat{}) -> L loc (gParPat p') -- #14875 _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs @@ -1322,7 +1322,7 @@ cvtp (ConP s ts ps) = do { s' <- cNameN s } } cvtp (InfixP p1 s p2) = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParLA (ParPat noAnn) $ + ; wrapParLA gParPat $ ConPat { pat_con_ext = noAnn , pat_con = s' @@ -1336,7 +1336,7 @@ cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Co cvtp (ParensP p) = do { p' <- cvtPat p; ; case unLoc p' of -- may be wrapped ConPatIn ParPat {} -> return $ unLoc p' - _ -> return $ ParPat noAnn p' } + _ -> return $ gParPat p' } cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noAnn p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noAnn p' } cvtp (TH.AsP s p) = do { s' <- vNameN s; p' <- cvtPat p diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 6f5150a1b4..b4d7b24dea 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -404,7 +404,9 @@ data HsExpr p -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | HsPar (XPar p) + !(LHsToken "(" p) (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + !(LHsToken ")" p) | SectionL (XSectionL p) (LHsExpr p) -- operand; see Note [Sections in HsSyn] @@ -928,7 +930,9 @@ data HsCmd id -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | HsCmdPar (XCmdPar id) + !(LHsToken "(" id) (LHsCmd id) -- parenthesised command + !(LHsToken ")" id) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, -- 'GHC.Parser.Annotation.AnnClose' @')'@ diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index f414968a6e..2f9b9d7583 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -22,6 +23,7 @@ module Language.Haskell.Syntax.Extension where import GHC.Prelude +import GHC.TypeLits (Symbol, KnownSymbol) import Data.Data hiding ( Fixity ) import Data.Kind (Type) import GHC.Utils.Outputable @@ -693,3 +695,14 @@ type family NoGhcTc (p :: Type) -- ===================================================================== -- End of Type family definitions -- ===================================================================== + + + +-- ===================================================================== +-- Token information + +type LHsToken tok p = XRec p (HsToken tok) + +data HsToken (tok :: Symbol) = HsTok + +deriving instance KnownSymbol tok => Data (HsToken tok) diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index c7829d833c..75dc7ddd00 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -9,6 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -74,7 +75,9 @@ data Pat p -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | ParPat (XParPat p) + !(LHsToken "(" p) (LPat p) -- ^ Parenthesised pattern + !(LHsToken ")" p) -- See Note [Parens in HsSyn] in GHC.Hs.Expr -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, -- 'GHC.Parser.Annotation.AnnClose' @')'@ |