From d24afd9d7139d7a62f3b465af1be50b25c15e5b5 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Sun, 15 May 2022 14:27:36 +0300 Subject: HsToken for @-patterns and TypeApplications (#19623) One more step towards the new design of EPA. --- compiler/GHC/Hs/Expr.hs | 4 ++-- compiler/GHC/Hs/Instances.hs | 4 ++++ compiler/GHC/Hs/Pat.hs | 13 +++++----- compiler/GHC/Hs/Syn/Type.hs | 4 ++-- compiler/GHC/Hs/Type.hs | 4 ++-- compiler/GHC/Hs/Utils.hs | 6 ++--- compiler/GHC/HsToCore/Expr.hs | 2 +- compiler/GHC/HsToCore/Match.hs | 6 ++--- compiler/GHC/HsToCore/Pmc/Desugar.hs | 2 +- compiler/GHC/HsToCore/Quote.hs | 8 ++++--- compiler/GHC/HsToCore/Ticks.hs | 6 ++--- compiler/GHC/HsToCore/Utils.hs | 2 +- compiler/GHC/Iface/Ext/Ast.hs | 20 +++++++++------- compiler/GHC/Parser.y | 4 ++-- compiler/GHC/Parser/Annotation.hs | 4 +++- compiler/GHC/Parser/Errors/Ppr.hs | 2 +- compiler/GHC/Parser/Errors/Types.hs | 2 +- compiler/GHC/Parser/PostProcess.hs | 28 +++++++++++----------- compiler/GHC/Parser/Types.hs | 4 ++-- compiler/GHC/Rename/Expr.hs | 10 ++++---- compiler/GHC/Rename/Module.hs | 2 +- compiler/GHC/Rename/Pat.hs | 16 +++++++------ compiler/GHC/Rename/Utils.hs | 2 +- compiler/GHC/Tc/Deriv/Generate.hs | 4 ++-- compiler/GHC/Tc/Gen/App.hs | 10 ++++---- compiler/GHC/Tc/Gen/Head.hs | 23 ++++++++++-------- compiler/GHC/Tc/Gen/Pat.hs | 8 +++---- compiler/GHC/Tc/TyCl/Instance.hs | 4 ++-- compiler/GHC/Tc/TyCl/PatSyn.hs | 2 +- compiler/GHC/Tc/Types/Origin.hs | 2 +- compiler/GHC/Tc/Utils/Zonk.hs | 8 +++---- compiler/GHC/ThToHs.hs | 7 +++--- compiler/Language/Haskell/Syntax/Expr.hs | 1 + compiler/Language/Haskell/Syntax/Extension.hs | 9 ++++++- compiler/Language/Haskell/Syntax/Pat.hs | 16 +++++++++++-- testsuite/tests/perf/compiler/hard_hole_fits.hs | 2 +- .../tests/perf/compiler/hard_hole_fits.stderr | 7 ++++-- utils/check-exact/ExactPrint.hs | 20 ++++++++-------- utils/check-exact/Lookup.hs | 2 -- utils/check-exact/Types.hs | 2 -- 40 files changed, 159 insertions(+), 123 deletions(-) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index d664456654..12e9e2d81c 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -247,7 +247,7 @@ type instance XLamCase (GhcPass _) = EpAnn [AddEpAnn] type instance XApp (GhcPass _) = EpAnnCO -type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives +type instance XAppTypeE GhcPs = NoExtField type instance XAppTypeE GhcRn = NoExtField type instance XAppTypeE GhcTc = Type @@ -730,7 +730,7 @@ ppr_apps :: (OutputableBndrId p) -> SDoc ppr_apps (HsApp _ (L _ fun) arg) args = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) arg) args +ppr_apps (HsAppType _ (L _ fun) _ arg) args = ppr_apps fun (Right arg : args) ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) where diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 3f4c0b16bd..0a723cee11 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -431,6 +431,10 @@ deriving instance Data (Pat GhcTc) deriving instance Data ConPatTc +deriving instance Data (HsConPatTyArg GhcPs) +deriving instance Data (HsConPatTyArg GhcRn) +deriving instance Data (HsConPatTyArg GhcTc) + deriving instance (Data a, Data b) => Data (HsFieldBind a b) deriving instance (Data body) => Data (HsRecFields GhcPs body) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index f3e4fbe9c4..102587026e 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -28,6 +28,7 @@ module GHC.Hs.Pat ( XXPatGhcTc(..), HsConPatDetails, hsConPatArgs, + HsConPatTyArg(..), HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, @@ -94,7 +95,7 @@ type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~' type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat GhcPs = EpAnn [AddEpAnn] -- For '@' +type instance XAsPat GhcPs = EpAnnCO type instance XAsPat GhcRn = NoExtField type instance XAsPat GhcTc = NoExtField @@ -307,7 +308,7 @@ pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat -pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', +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) @@ -382,7 +383,7 @@ pprConArgs :: (OutputableBndrId p, Outputable (Anno (IdGhcP p))) => HsConPatDetails (GhcPass p) -> SDoc pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats) - where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs) + where pprTyArgs tyargs = fsep (map ppr tyargs) pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats @@ -475,7 +476,7 @@ looksLazyLPat = looksLazyPat . unLoc looksLazyPat :: Pat (GhcPass p) -> Bool looksLazyPat (ParPat _ _ p _) = looksLazyLPat p -looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ _ p) = looksLazyLPat p looksLazyPat (BangPat {}) = False looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False @@ -542,7 +543,7 @@ isIrrefutableHsPat' is_strict = goL | otherwise = True go (BangPat _ pat) = goL pat go (ParPat _ _ pat _) = goL pat - go (AsPat _ _ pat) = goL pat + go (AsPat _ _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat go (TuplePat _ pats _) = all goL pats @@ -699,7 +700,7 @@ collectEvVarsPat :: Pat GhcTc -> Bag EvVar collectEvVarsPat pat = case pat of LazyPat _ p -> collectEvVarsLPat p - AsPat _ _ p -> collectEvVarsLPat p + AsPat _ _ _ p -> collectEvVarsLPat p ParPat _ _ p _ -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index 63b568df4a..2e40cec8d0 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -48,7 +48,7 @@ hsPatType (VarPat _ lvar) = idType (unLoc lvar) hsPatType (BangPat _ pat) = hsLPatType pat hsPatType (LazyPat _ pat) = hsLPatType pat hsPatType (LitPat _ lit) = hsLitType lit -hsPatType (AsPat _ var _) = idType (unLoc var) +hsPatType (AsPat _ var _ _) = idType (unLoc var) hsPatType (ViewPat ty _ _) = ty hsPatType (ListPat ty _) = mkListTy ty hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys @@ -101,7 +101,7 @@ hsExprType (HsLit _ lit) = hsLitType lit hsExprType (HsLam _ (MG { mg_ext = match_group })) = matchGroupTcType match_group hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f -hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x +hsExprType (HsAppType x f _ _) = piResultTy (lhsExprType f) x hsExprType (OpApp v _ _ _) = dataConCantHappen v hsExprType (NegApp _ _ se) = syntaxExprType se hsExprType (HsPar _ _ e _) = lhsExprType e diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index fe9aad3475..1635019dbe 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -203,7 +203,7 @@ type instance XHsWC GhcTc b = [Name] type instance XXHsWildCardBndrs (GhcPass _) _ = DataConCantHappen -type instance XHsPS GhcPs = EpAnn EpaLocation +type instance XHsPS GhcPs = EpAnnCO type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn @@ -252,7 +252,7 @@ mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = noExtField } -mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs +mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs mkHsPatSigType ann x = HsPS { hsps_ext = ann , hsps_body = x } diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 4dd0aab928..21e32825f5 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -244,7 +244,7 @@ mkHsAppsWith mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn -mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct) +mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e noHsTok paren_wct) where t_body = hswc_body t paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } @@ -1188,7 +1188,7 @@ collect_pat flag pat bndrs = case pat of WildPat _ -> bndrs LazyPat _ pat -> collect_lpat flag pat bndrs BangPat _ pat -> collect_lpat flag pat bndrs - AsPat _ a pat -> unXRec @p a : 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 ListPat _ pats -> foldr (collect_lpat flag) bndrs pats @@ -1584,7 +1584,7 @@ lPatImplicits = hs_lpat hs_pat (LazyPat _ pat) = hs_lpat pat hs_pat (BangPat _ pat) = hs_lpat pat - hs_pat (AsPat _ _ 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 (ListPat _ pats) = hs_lpats pats diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 834be5907d..655a9cc37a 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -841,7 +841,7 @@ dsHsWrapped orig_hs_expr = go wrap hs_e go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e))) = go (wrap1 <.> wrap2) hs_e - go wrap (HsAppType ty (L _ hs_e) _) + go wrap (HsAppType ty (L _ hs_e) _ _) = go (wrap <.> WpTyApp ty) hs_e go wrap (HsVar _ (L _ var)) diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 1780c30755..0cc5907c2b 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -430,7 +430,7 @@ tidy1 v _ (VarPat _ (L _ var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v o (AsPat _ (L _ var) pat) +tidy1 v o (AsPat _ (L _ var) _ pat) = do { (wrap, pat') <- tidy1 v o (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -517,8 +517,8 @@ 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 -- it may disappear next time -tidy_bang_pat v o l (AsPat x v' p) - = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) +tidy_bang_pat v o l (AsPat x v' at p) + = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p))) tidy_bang_pat v o l (XPat (CoPat w p t)) = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t) diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index 38d3fd54d7..c0d0d9f0e9 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -119,7 +119,7 @@ desugarPat x pat = case pat of -- (x@pat) ==> Desugar pat with x as match var and handle impedance -- mismatch with incoming match var - AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> desugarLPat y p + AsPat _ (L _ y) _ p -> (mkPmLetVar y x ++) <$> desugarLPat y p SigPat _ p _ty -> desugarLPat x p diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 5f08571bf2..015ecb56f6 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1511,7 +1511,8 @@ repE (HsLamCase _ LamCases (MG { mg_alts = (L _ ms) })) ; core_ms <- coreListM matchTyConName ms' ; repLamCases core_ms } repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType _ e t) = do { a <- repLE e +repE (HsAppType _ e _ t) + = do { a <- repLE e ; s <- repLTy (hswc_body t) ; repAppType a s } @@ -2055,7 +2056,7 @@ repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } 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 +repP (AsPat _ x _ p) = do { x' <- lookupNBinder x; p1 <- repLP p ; repPaspat x' p1 } repP (ParPat _ _ p _) = repLP p repP (ListPat _ ps) = do { qs <- repLPs ps; repPlist qs } @@ -2068,7 +2069,8 @@ repP (ConPat NoExtField dc details) = do { con_str <- lookupLOcc dc ; case details of PrefixCon tyargs ps -> do { qs <- repLPs ps - ; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs + ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hsps_body t) + ; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs ; repPcon con_str ts qs } RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec) ; repPrec con_str fps } diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs index 860bf597bb..e2925de058 100644 --- a/compiler/GHC/HsToCore/Ticks.hs +++ b/compiler/GHC/HsToCore/Ticks.hs @@ -475,9 +475,9 @@ addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant) (addTickMatchGroup True mgs) addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) (addTickLHsExpr e2) -addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x) - (addTickLHsExprNever e) - (return ty) +addTickHsExpr (HsAppType x e at ty) = do + e' <- addTickLHsExprNever e + return (HsAppType x e' at ty) addTickHsExpr (OpApp fix e1 e2 e3) = liftM4 OpApp (return fix) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index b6725331a1..e3c6ef1333 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -142,7 +142,7 @@ selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- multiplicity stored within the variable -- itself. It's easier to pull it from the -- variable, so we ignore the multiplicity. -selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var)) +selectMatchVar _w (AsPat _ var _ _) = assert (isManyDataConTy _w ) (return (unLoc var)) selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) {- Note [Localise pattern binders] diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index e92327f6d7..9547296fe0 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -496,15 +496,15 @@ patScopes rsp useScope patScope xs = map (\(RS sc a) -> PS rsp useScope sc a) $ listScopes patScope xs --- | 'listScopes' specialised to 'HsPatSigType' -tScopes +-- | 'listScopes' specialised to 'HsConPatTyArg' +taScopes :: Scope -> Scope - -> [HsPatSigType (GhcPass a)] + -> [HsConPatTyArg (GhcPass a)] -> [TScoped (HsPatSigType (GhcPass a))] -tScopes scope rhsScope xs = +taScopes scope rhsScope xs = map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $ - listScopes rhsScope (map (\hsps -> L (getLoc $ hsps_body hsps) hsps) xs) + listScopes rhsScope (map (\(HsConPatTyArg _ hsps) -> L (getLoc $ hsps_body hsps) hsps) xs) -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType. -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS. @@ -964,7 +964,7 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where LazyPat _ p -> [ toHie $ PS rsp scope pscope p ] - AsPat _ lname pat -> + AsPat _ lname _ pat -> [ toHie $ C (PatternBind scope (combineScopes (mkLScopeA pat) pscope) rsp) @@ -1039,9 +1039,11 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where ] ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] where - contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType GhcRn) a (HsRecFields (GhcPass p) a) + contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsConPatTyArg GhcRn) a (HsRecFields (GhcPass p) a) -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) - contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args) + contextify (PrefixCon tyargs args) = + PrefixCon (taScopes scope argscope tyargs) + (patScopes rsp scope pscope args) where argscope = foldr combineScopes NoScope $ map mkLScopeA args contextify (InfixCon a b) = InfixCon a' b' where [a', b'] = patScopes rsp scope pscope [a,b] @@ -1105,7 +1107,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where [ toHie a , toHie b ] - HsAppType _ expr sig -> + HsAppType _ expr _ sig -> [ toHie expr , toHie $ TS (ResolvedScopes []) sig ] diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index a238dac301..9d45b0c7c8 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2769,7 +2769,7 @@ fexp :: { ECP } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer | fexp PREFIX_AT atype { ECP $ unECP $1 >>= \ $1 -> - mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (getLoc $2) $3 } + mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (hsTok $2) $3 } | 'static' aexp {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ @@ -2782,7 +2782,7 @@ aexp :: { ECP } : qvar TIGHT_INFIX_AT aexp { ECP $ unECP $3 >>= \ $3 -> - mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 $3 [mj AnnAt $2] } + mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 (hsTok $2) $3 } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index d3119fb920..2f00422f8b 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -202,7 +202,6 @@ https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations data AnnKeywordId = AnnAnyclass | AnnAs - | AnnAt | AnnBang -- ^ '!' | AnnBackquote -- ^ '`' | AnnBy @@ -414,6 +413,9 @@ data EpaLocation = EpaSpan !RealSrcSpan data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation deriving (Data,Eq) +instance Outputable a => Outputable (GenLocated TokenLocation a) where + ppr (L _ x) = ppr x + -- | Spacing between output items when exact printing. It captures -- the spacing from the current print position on the page to the -- position required for the thing about to be printed. This is diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index d108673e9c..efe708bfee 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -445,7 +445,7 @@ instance Diagnostic PsMessage where PEIP_NegApp -> text "-" <> ppr s PEIP_TypeArgs peipd_tyargs | not (null peipd_tyargs) -> ppr s <+> vcat [ - hsep [text "@" <> ppr t | t <- peipd_tyargs] + hsep (map ppr peipd_tyargs) , text "Type applications in patterns are only allowed on data constructors." ] | otherwise -> ppr s diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index 7f40c73635..18b6d60807 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -504,7 +504,7 @@ data ParseContext data PsErrInPatDetails = PEIP_NegApp -- ^ Negative application pattern? - | PEIP_TypeArgs [HsPatSigType GhcPs] + | PEIP_TypeArgs [HsConPatTyArg GhcPs] -- ^ The list of type arguments for the pattern | PEIP_RecPattern [LPat GhcPs] -- ^ The pattern arguments !PatIsRecursive -- ^ Is the parsed pattern recursive? diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 902e23e08c..94b689fe71 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1158,7 +1158,7 @@ checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkL checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] -checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] +checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args | isRdrDataCon c = return . L loc $ ConPat @@ -1171,8 +1171,8 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args | (not (null args) && patIsRec c) = do ctx <- askParseContext patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx -checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = - checkPat loc f (t : tyargs) args +checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args = + checkPat loc f (HsConPatTyArg at t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do p <- checkLPat e checkPat loc f [] (p : args) @@ -1530,7 +1530,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | Disambiguate "f x" (function application) mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b) -- | Disambiguate "f @t" (visible type application) - mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) + mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate "if ... then ... else ..." mkHsIfPV :: SrcSpan -> LHsExpr GhcPs @@ -1583,7 +1583,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) -- | Disambiguate "a@b" (as-pattern) mkHsAsPatPV - :: SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) + :: SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b) -- | Disambiguate "~a" (lazy pattern) mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) -- | Disambiguate "!a" (bang pattern) @@ -1703,7 +1703,7 @@ instance DisambECP (HsCmd GhcPs) where in pp_op <> ppr c mkHsViewPatPV l a b _ = cmdFail l $ ppr a <+> text "->" <+> ppr b - mkHsAsPatPV l v c _ = cmdFail l $ + mkHsAsPatPV l v _ c = cmdFail l $ pprPrefixOcc (unLoc v) <> text "@" <> ppr c mkHsLazyPatPV l c _ = cmdFail l $ text "~" <> ppr c @@ -1757,9 +1757,9 @@ instance DisambECP (HsExpr GhcPs) where checkExpBlockArguments e1 checkExpBlockArguments e2 return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2) - mkHsAppTypePV l e la t = do + mkHsAppTypePV l e at t = do checkExpBlockArguments e - return $ L l (HsAppType la e (mkHsWildCardBndrs t)) + return $ L l (HsAppType noExtField e at (mkHsWildCardBndrs t)) mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b cs <- getCommentsFor l @@ -1799,7 +1799,7 @@ instance DisambECP (HsExpr GhcPs) where return $ L l (SectionR (comment (realSrcSpan l) cs) op e) mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsAsPatPV l v e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) + mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) @@ -1839,10 +1839,10 @@ instance DisambECP (PatBuilder GhcPs) where type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) - mkHsAppTypePV l p la t = do + mkHsAppTypePV l p at t = do cs <- getCommentsFor (locA l) - let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs - return $ L l (PatBuilderAppType p (mkHsPatSigType anns t)) + let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs + return $ L l (PatBuilderAppType p at (mkHsPatSigType anns t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) @@ -1881,10 +1881,10 @@ instance DisambECP (PatBuilder GhcPs) where p <- checkLPat b cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p)) - mkHsAsPatPV l v e a = do + mkHsAsPatPV l v at e = do p <- checkLPat e cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) a cs) v p)) + return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) NoEpAnns cs) v at p)) mkHsLazyPatPV l e a = do p <- checkLPat e cs <- getCommentsFor l diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs index 36abbe5125..6ea37dda6d 100644 --- a/compiler/GHC/Parser/Types.hs +++ b/compiler/GHC/Parser/Types.hs @@ -55,7 +55,7 @@ data PatBuilder p = PatBuilderPat (Pat p) | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p) | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) - | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs) + | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsPatSigType GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) | PatBuilderVar (LocatedN RdrName) @@ -65,7 +65,7 @@ instance Outputable (PatBuilder GhcPs) where ppr (PatBuilderPat p) = 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 (PatBuilderAppType (L _ p) _ t) = ppr p <+> text "@" <> ppr t ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2 ppr (PatBuilderVar v) = ppr v ppr (PatBuilderOverLit l) = ppr l diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 70233c0854..8503dc400c 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -283,7 +283,7 @@ rnExpr (HsUnboundVar _ v) rnExpr (HsOverLabel _ v) = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName ; return ( mkExpandedExpr (HsOverLabel noAnn v) $ - HsAppType noExtField (genLHsVar from_label) hs_ty_arg + HsAppType noExtField (genLHsVar from_label) noHsTok hs_ty_arg , fvs ) } where hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $ @@ -314,12 +314,12 @@ rnExpr (HsApp x fun arg) ; (arg',fvArg) <- rnLExpr arg ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType _ fun arg) +rnExpr (HsAppType _ fun at arg) = do { type_app <- xoptM LangExt.TypeApplications ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg ; (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) } + ; return (HsAppType NoExtField fun' at arg', fvFun `plusFV` fvArg) } rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -2250,7 +2250,7 @@ isStrictPattern (L loc pat) = WildPat{} -> False VarPat{} -> False LazyPat{} -> False - AsPat _ _ p -> isStrictPattern p + AsPat _ _ _ p -> isStrictPattern p ParPat _ _ p _ -> isStrictPattern p ViewPat _ _ p -> isStrictPattern p SigPat _ p _ -> isStrictPattern p @@ -2423,7 +2423,7 @@ isReturnApp monad_names (L loc e) mb_pure = 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/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 1755b6a1ef..be6dd17006 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1325,7 +1325,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 _ lv) | (unLoc lv) `notElem` foralls = Nothing check other = Just other -- Failure diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index b64d1141e7..7886cebdf3 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -77,7 +77,7 @@ import GHC.Core.DataCon import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt -import Control.Monad ( when, ap, guard, forM, unless ) +import Control.Monad ( when, ap, guard, unless ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio @@ -551,10 +551,10 @@ rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ ) (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat _ rdr pat) +rnPatAndThen mk (AsPat _ rdr at pat) = do { new_name <- newPatLName mk rdr ; pat' <- rnLPatAndThen mk pat - ; return (AsPat noExtField new_name pat') } + ; return (AsPat noExtField new_name at pat') } rnPatAndThen mk p@(ViewPat _ expr pat) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns @@ -626,8 +626,7 @@ rnConPatAndThen :: NameMaker rnConPatAndThen mk con (PrefixCon tyargs pats) = do { con' <- lookupConCps con ; liftCps check_lang_exts - ; tyargs' <- forM tyargs $ \t -> - liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t + ; tyargs' <- mapM rnConPatTyArg tyargs ; pats' <- rnLPatsAndThen mk pats ; return $ ConPat { pat_con_ext = noExtField @@ -642,12 +641,15 @@ rnConPatAndThen mk con (PrefixCon tyargs pats) type_app <- xoptM LangExt.TypeApplications unless (scoped_tyvars && type_app) $ case listToMaybe tyargs of - Nothing -> pure () + Nothing -> pure () Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal visible type application in a pattern:" - <+> quotes (char '@' <> ppr tyarg)) + <+> quotes (ppr tyarg)) 2 (text "Both ScopedTypeVariables and TypeApplications are" <+> text "required to use this feature") + rnConPatTyArg (HsConPatTyArg at t) = do + t' <- liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t + return (HsConPatTyArg at t') rnConPatAndThen mk con (InfixCon pat1 pat2) = do { con' <- lookupConCps con diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index bb6cedf395..539b36ddc2 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -674,7 +674,7 @@ genHsVar :: Name -> HsExpr GhcRn genHsVar nm = HsVar noExtField $ wrapGenSpan nm genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn -genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan +genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty)) genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn) genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index ad30052579..a8536971bd 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -852,7 +852,7 @@ gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do enum_index = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [noLocA (AsPat noAnn (noLocA c_RDR) + [noLocA (AsPat noAnn (noLocA c_RDR) noHsTok (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr [(a_RDR, ah_RDR)] ( @@ -2105,7 +2105,7 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty rep_cvs' = scopedSort rep_cvs nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty) +nlHsAppType e s = noLocA (HsAppType noExtField e noHsTok hs_ty) where hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index ecb79b8248..02cce2e38a 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -427,9 +427,9 @@ tcValArgs do_ql args = mapM tc_arg args where tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc) - tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p)) - tc_arg (EWrap w) = return (EWrap w) - tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty) + tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p)) + tc_arg (EWrap w) = return (EWrap w) + tc_arg (ETypeArg l at hs_ty ty) = return (ETypeArg l at hs_ty ty) tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty , eva_ctxt = ctxt }) @@ -594,14 +594,14 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args = go1 delta (EPrag sp prag : acc) so_far fun_ty args -- Rule ITYARG from Fig 4 of the QL paper - go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty } + go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_at = at, eva_hs_ty = hs_ty } : rest_args ) | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] = go delta acc so_far fun_ty rest_args | otherwise = do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty - ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty, eva_ty = ty_arg } + ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_at = at, eva_hs_ty = hs_ty, eva_ty = ty_arg } ; go delta (arg' : acc) so_far inst_ty rest_args } -- Rule IVAR from Fig 4 of the QL paper: diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index af4575c490..a56b9c833e 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -172,6 +172,7 @@ data HsExprArg (p :: TcPass) , eva_arg_ty :: !(XEVAType p) } | ETypeArg { eva_ctxt :: AppCtxt + , eva_at :: !(LHsToken "@" GhcRn) , eva_hs_ty :: LHsWcType GhcRn -- The type arg , eva_ty :: !(XETAType p) } -- Kind-checked type arg @@ -263,9 +264,11 @@ mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt , eva_arg_ty = noExtField } -mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn -mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty - , eva_ty = noExtField } +mkETypeArg :: AppCtxt -> LHsToken "@" GhcRn -> LHsWcType GhcRn -> HsExprArg 'TcpRn +mkETypeArg ctxt at hs_ty = + ETypeArg { eva_ctxt = ctxt + , eva_at = at, eva_hs_ty = hs_ty + , eva_ty = noExtField } addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst] addArgWrap wrap args @@ -284,7 +287,7 @@ splitHsApps e = go e (top_ctxt 0 e) [] -- See Note [AppCtxt] 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 (HsAppType _ fun _ _) = top_lctxt (n+1) fun top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan top_ctxt n other_fun = VACall other_fun n noSrcSpan @@ -294,10 +297,10 @@ splitHsApps e = go e (top_ctxt 0 e) [] go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) -- Modify the AppCtxt as we walk inwards, so it describes the next argument - 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) + 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) at ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt at ty : args) + go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args) -- See Note [Looking through HsExpanded] go (XExpr (HsExpanded orig fun)) ctxt args @@ -356,8 +359,8 @@ rebuild_hs_apps fun ctxt (arg : args) = case arg of EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } -> rebuild_hs_apps (HsApp noAnn lfun arg) ctxt' args - ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } - -> rebuild_hs_apps (HsAppType ty lfun hs_ty) ctxt' args + ETypeArg { eva_hs_ty = hs_ty, eva_at = at, eva_ty = ty, eva_ctxt = ctxt' } + -> rebuild_hs_apps (HsAppType ty lfun at hs_ty) ctxt' args EPrag ctxt' p -> rebuild_hs_apps (HsPragE noExtField p lfun) ctxt' args EWrap (EPar ctxt') diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 9a0caedd11..83bb70e35f 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -403,7 +403,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of ; pat_ty <- expTypeToType (scaledThing pat_ty) ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } - AsPat x (L nm_loc name) pat -> do + AsPat x (L nm_loc name) at pat -> do { mult_wrap <- checkManyPattern pat_ty -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty) @@ -418,7 +418,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) at pat') pat_ty, res) } ViewPat _ expr pat -> do { mult_wrap <- checkManyPattern pat_ty @@ -1320,8 +1320,8 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of -- dataConFieldLabels will be empty (and each field in the pattern -- will generate an error below). -tcConTyArg :: Checker (HsPatSigType GhcRn) TcType -tcConTyArg penv rn_ty thing_inside +tcConTyArg :: Checker (HsConPatTyArg GhcRn) TcType +tcConTyArg penv (HsConPatTyArg _ rn_ty) thing_inside = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsPatSigType TypeAppCtxt HM_TyAppPat rn_ty AnyKind -- AnyKind is a bit suspect: it really should be the kind gotten -- from instantiating the constructor type. But this would be diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 90951272a2..160d8ceae9 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -2141,8 +2141,8 @@ mkDefMethBind dfun_id clas sel_id dm_name (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id) mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLocA (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy - $ noLocA $ XHsType ty)) + mk_vta fun ty = noLocA (HsAppType noExtField fun noHsTok + (mkEmptyWildCardBndrs $ nlHsParTy $ noLocA $ XHsType ty)) -- NB: use visible type application -- See Note [Default methods in instances] diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index eb31cec392..8da94d2ec0 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -1271,7 +1271,7 @@ tcCollectEx pat = go pat go1 :: Pat GhcTc -> ([TyVar], [EvVar]) go1 (LazyPat _ p) = go p - go1 (AsPat _ _ p) = go p + go1 (AsPat _ _ _ p) = go p go1 (ParPat _ _ p _) = go p go1 (BangPat _ p) = go p go1 (ListPat _ ps) = mergeMany . map go $ ps diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 137ee8f02e..1b7d4de3fd 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -684,7 +684,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/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 2180a113da..e8b5f8252e 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -771,10 +771,10 @@ zonkExpr env (HsApp x e1 e2) new_e2 <- zonkLExpr env e2 return (HsApp x new_e1 new_e2) -zonkExpr env (HsAppType ty e t) +zonkExpr env (HsAppType ty e at t) = do new_e <- zonkLExpr env e new_ty <- zonkTcTypeToTypeX env ty - return (HsAppType new_ty new_e t) + return (HsAppType new_ty new_e at t) -- NB: the type is an HsType; can't zonk that! zonkExpr env (HsTypedBracket hsb_tc body) @@ -1317,10 +1317,10 @@ zonk_pat env (BangPat x pat) = do { (env', pat') <- zonkPat env pat ; return (env', BangPat x pat') } -zonk_pat env (AsPat x (L loc v) pat) +zonk_pat env (AsPat x (L loc v) at pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat - ; return (env', AsPat x (L loc v') pat') } + ; return (env', AsPat x (L loc v') at pat') } zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 401f8c8a1d..441c84bad7 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1002,7 +1002,7 @@ cvtl e = wrapLA (cvt e) cvt (AppTypeE e t) = do { e' <- cvtl e ; t' <- cvtType t ; let tp = parenthesizeHsType appPrec t' - ; return $ HsAppType noSrcSpan e' + ; return $ HsAppType noExtField e' noHsTok $ mkHsWildCardBndrs tp } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing @@ -1387,10 +1387,11 @@ cvtp (ConP s ts ps) = do { s' <- cNameN s ; ps' <- cvtPats ps ; ts' <- mapM cvtType ts ; let pps = map (parenthesizePat appPrec) ps' + pts = map (\t -> HsConPatTyArg noHsTok (mkHsPatSigType noAnn t)) ts' ; return $ ConPat { pat_con_ext = noAnn , pat_con = s' - , pat_args = PrefixCon (map (mkHsPatSigType noAnn) ts') pps + , pat_args = PrefixCon pts pps } } cvtp (InfixP p1 s p2) = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2 @@ -1412,7 +1413,7 @@ cvtp (ParensP p) = do { p' <- cvtPat 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 - ; return $ AsPat noAnn s' p' } + ; return $ AsPat noAnn s' noHsTok p' } cvtp TH.WildP = return $ WildPat noExtField cvtp (RecP c fs) = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs ; return $ ConPat diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 051edda97f..8d2a365a8c 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -371,6 +371,7 @@ data HsExpr p | HsAppType (XAppTypeE p) -- After typechecking: the type argument (LHsExpr p) + !(LHsToken "@" p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 5cffd96690..47b693a9bd 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -23,7 +23,7 @@ module Language.Haskell.Syntax.Extension where import GHC.Prelude -import GHC.TypeLits (Symbol, KnownSymbol) +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.Data hiding ( Fixity ) import Data.Kind (Type) import GHC.Utils.Outputable @@ -730,3 +730,10 @@ type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) + +instance KnownSymbol tok => Outputable (HsToken tok) where + ppr _ = text (symbolVal (Proxy :: Proxy tok)) + +instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where + ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok)) + ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok)) diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index 0e9f11dc1b..12ef7ae98a 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -23,6 +23,7 @@ module Language.Haskell.Syntax.Pat ( ConLikeP, HsConPatDetails, hsConPatArgs, + HsConPatTyArg(..), HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, @@ -69,7 +70,9 @@ data Pat p -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | AsPat (XAsPat p) - (LIdP p) (LPat p) -- ^ As pattern + (LIdP p) + !(LHsToken "@" p) + (LPat p) -- ^ As pattern -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation @@ -217,9 +220,15 @@ type family ConLikeP x -- --------------------------------------------------------------------- +-- | Type argument in a data constructor pattern, +-- e.g. the @\@a@ in @f (Just \@a x) = ...@. +data HsConPatTyArg p = + HsConPatTyArg + !(LHsToken "@" p) + (HsPatSigType p) -- | Haskell Constructor Pattern Details -type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) +type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps @@ -353,6 +362,9 @@ hsRecFieldSel = foExt . unXRec @p . hfbLHS ************************************************************************ -} +instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where + ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty + instance (Outputable arg, Outputable (XRec p (HsRecField p arg))) => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.hs b/testsuite/tests/perf/compiler/hard_hole_fits.hs index d449a935b2..59d08c7f24 100644 --- a/testsuite/tests/perf/compiler/hard_hole_fits.hs +++ b/testsuite/tests/perf/compiler/hard_hole_fits.hs @@ -20,7 +20,7 @@ testMe (HsLit xle hl) = _ testMe (HsLam xl mg) = _ testMe (HsLamCase xlc lc_variant mg) = _ testMe (HsApp xa gl gl') = _ -testMe (HsAppType xate gl hwcb) = _ +testMe (HsAppType xate gl at hwcb) = _ testMe (OpApp xoa gl gl' gl2) = _ testMe (NegApp xna gl se) = _ testMe (HsPar xp gl ab ac) = _ diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr index 4caef50d4c..01df15c56c 100644 --- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr +++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr @@ -172,12 +172,15 @@ hard_hole_fits.hs:22:28: warning: [-Wtyped-holes (in -Wdefault)] (imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20 (and originally defined in ‘GHC.Enum’)) -hard_hole_fits.hs:23:35: warning: [-Wtyped-holes (in -Wdefault)] +hard_hole_fits.hs:23:38: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int - • In an equation for ‘testMe’: testMe (HsAppType xate gl hwcb) = _ + • In an equation for ‘testMe’: + testMe (HsAppType xate gl at hwcb) = _ • Relevant bindings include hwcb :: Language.Haskell.Syntax.Type.LHsWcType (Language.Haskell.Syntax.Extension.NoGhcTc GhcPs) + (bound at hard_hole_fits.hs:23:30) + at :: Language.Haskell.Syntax.Extension.LHsToken "@" GhcPs (bound at hard_hole_fits.hs:23:27) gl :: LHsExpr GhcPs (bound at hard_hole_fits.hs:23:24) xate :: Language.Haskell.Syntax.Extension.XAppTypeE GhcPs diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 05c6a1e792..9d5f932f1e 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -1837,7 +1837,7 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsLam _ _) = NoEntryVal getAnnotationEntry (HsLamCase an _ _) = fromAnn an getAnnotationEntry (HsApp an _ _) = fromAnn an - getAnnotationEntry (HsAppType _ _ _) = NoEntryVal + getAnnotationEntry (HsAppType _ _ _ _) = NoEntryVal getAnnotationEntry (OpApp an _ _ _) = fromAnn an getAnnotationEntry (NegApp an _ _) = fromAnn an getAnnotationEntry (HsPar an _ _ _) = fromAnn an @@ -1912,9 +1912,9 @@ instance ExactPrint (HsExpr GhcPs) where debugM $ "HsApp entered. p=" ++ show p markAnnotated e1 markAnnotated e2 - exact (HsAppType ss fun arg) = do + exact (HsAppType _ fun at arg) = do markAnnotated fun - printStringAtSs ss "@" + markToken at markAnnotated arg exact (OpApp _an e1 e2 e3) = do markAnnotated e1 @@ -3547,7 +3547,7 @@ instance ExactPrint (Pat GhcPs) where getAnnotationEntry (WildPat _) = NoEntryVal getAnnotationEntry (VarPat _ _) = NoEntryVal getAnnotationEntry (LazyPat an _) = fromAnn an - getAnnotationEntry (AsPat an _ _) = fromAnn an + getAnnotationEntry (AsPat an _ _ _) = fromAnn an getAnnotationEntry (ParPat an _ _ _) = fromAnn an getAnnotationEntry (BangPat an _) = fromAnn an getAnnotationEntry (ListPat an _) = fromAnn an @@ -3573,9 +3573,9 @@ instance ExactPrint (Pat GhcPs) where exact (LazyPat an pat) = do markEpAnn an AnnTilde markAnnotated pat - exact (AsPat an n pat) = do + exact (AsPat _an n at pat) = do markAnnotated n - markEpAnn an AnnAt + markToken at markAnnotated pat exact (ParPat _an lpar pat rpar) = do markToken lpar @@ -3633,10 +3633,7 @@ instance ExactPrint (Pat GhcPs) where instance ExactPrint (HsPatSigType GhcPs) where getAnnotationEntry = const NoEntryVal - - exact (HsPS an ty) = do - markAnnKw an id AnnAt - markAnnotated ty + exact (HsPS _ ty) = markAnnotated ty -- --------------------------------------------------------------------- @@ -3693,6 +3690,9 @@ exactUserCon an c details = do exactConArgs details markEpAnn an AnnCloseC +instance ExactPrint (HsConPatTyArg GhcPs) where + getAnnotationEntry _ = NoEntryVal + exact (HsConPatTyArg at tyarg) = markToken at >> markAnnotated tyarg exactConArgs ::HsConPatDetails GhcPs -> EPP () exactConArgs (PrefixCon tyargs pats) = markAnnotated tyargs >> markAnnotated pats diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs index 3cd53be04c..467f76c686 100644 --- a/utils/check-exact/Lookup.hs +++ b/utils/check-exact/Lookup.hs @@ -33,7 +33,6 @@ keywordToString kw = (G AnnValStr ) -> mkErr kw (G AnnName ) -> mkErr kw (G AnnAs ) -> "as" - (G AnnAt ) -> "@" (G AnnBang ) -> "!" (G AnnBackquote ) -> "`" (G AnnBy ) -> "by" @@ -126,5 +125,4 @@ keywordToString kw = (G AnnRarrowtailU) -> "⤜" (G AnnlarrowtailU) -> "⤙" (G AnnrarrowtailU) -> "⤚" - AnnTypeApp -> "@" (G AnnVia) -> "via" diff --git a/utils/check-exact/Types.hs b/utils/check-exact/Types.hs index ef08421583..b9c6981671 100644 --- a/utils/check-exact/Types.hs +++ b/utils/check-exact/Types.hs @@ -156,7 +156,6 @@ instance Outputable Comment where -- AST. data KeywordId = G AnnKeywordId -- ^ A normal keyword | AnnSemiSep -- ^ A separating comma - | AnnTypeApp -- ^ Visible type application annotation | AnnComment Comment | AnnString String -- ^ Used to pass information from -- Delta to Print when we have to work @@ -167,7 +166,6 @@ data KeywordId = G AnnKeywordId -- ^ A normal keyword instance Show KeywordId where show (G gc) = "(G " ++ show gc ++ ")" show AnnSemiSep = "AnnSemiSep" - show AnnTypeApp = "AnnTypeApp" show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")" show (AnnString s) = "(AnnString " ++ s ++ ")" -- cgit v1.2.1