From 92cb7711f8dca14701aaa702199418c3063f5ede Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 16 May 2021 14:58:45 +0100 Subject: EPA: AnnAt missing for type application in patterns Ensure that the exact print annotations accurately record the `@` for code like tyApp :: Con k a -> Proxy a tyApp (Con @kx @ax (x :: Proxy ax)) = x :: Proxy (ax :: kx) Closes #19850 --- compiler/GHC/Hs/Type.hs | 8 ++++---- compiler/GHC/Parser/PostProcess.hs | 11 +++++++---- compiler/GHC/Parser/Types.hs | 4 ++-- compiler/GHC/ThToHs.hs | 6 +++--- testsuite/tests/printer/Makefile | 5 +++++ testsuite/tests/printer/Test19850.hs | 14 ++++++++++++++ testsuite/tests/printer/all.T | 1 + utils/check-exact/ExactPrint.hs | 4 +++- utils/check-exact/Main.hs | 3 ++- 9 files changed, 41 insertions(+), 15 deletions(-) create mode 100644 testsuite/tests/printer/Test19850.hs diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 17d84c2d02..0b5457c35e 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -198,7 +198,7 @@ type instance XHsWC GhcTc b = [Name] type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon -type instance XHsPS GhcPs = NoExtField +type instance XHsPS GhcPs = EpAnn EpaLocation type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn @@ -247,9 +247,9 @@ mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = noExtField } -mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs -mkHsPatSigType x = HsPS { hsps_ext = noExtField - , hsps_body = x } +mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs +mkHsPatSigType ann x = HsPS { hsps_ext = ann + , hsps_body = x } mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 62d6c6b834..d6b36b9d51 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -874,7 +874,7 @@ mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] mkRuleBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v cvt_one (RuleTyTmVar ann v (Just sig)) = - RuleBndrSig ann v (mkHsPatSigType sig) + RuleBndrSig ann v (mkHsPatSigType noAnn sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] @@ -1095,7 +1095,7 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args | not (null args) && patIsRec c = add_hint (SuggestExtension LangExt.RecursiveDo) $ patFail (locA l) (ppr e) -checkPat loc (L _ (PatBuilderAppType f _ t)) tyargs args = +checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = checkPat loc f (t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do p <- checkLPat e @@ -1748,7 +1748,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 = return $ L l (PatBuilderAppType p la (mkHsPatSigType t)) + mkHsAppTypePV l p la 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)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l mkHsDoPV l _ _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l mkHsParPV l p an = return $ L (noAnnSrcSpan l) (PatBuilderPar p an) @@ -1761,7 +1764,7 @@ instance DisambECP (PatBuilder GhcPs) where mkHsTySigPV l b sig anns = do p <- checkLPat b cs <- getCommentsFor (locA l) - return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType sig))) + return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig))) mkHsExplicitListPV l xs anns = do ps <- traverse checkLPat xs cs <- getCommentsFor l diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs index 5369367ed2..b42d04f881 100644 --- a/compiler/GHC/Parser/Types.hs +++ b/compiler/GHC/Parser/Types.hs @@ -54,7 +54,7 @@ data PatBuilder p = PatBuilderPat (Pat p) | PatBuilderPar (LocatedA (PatBuilder p)) AnnParen | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) - | PatBuilderAppType (LocatedA (PatBuilder p)) SrcSpan (HsPatSigType GhcPs) + | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) | PatBuilderVar (LocatedN RdrName) @@ -64,7 +64,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/ThToHs.hs b/compiler/GHC/ThToHs.hs index fa558f41ae..f2f9695109 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -874,7 +874,7 @@ cvtRuleBndr (RuleVar n) cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameN n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType ty' } + ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } --------------------------------------------------- -- Declarations @@ -1318,7 +1318,7 @@ cvtp (ConP s ts ps) = do { s' <- cNameN s ; return $ ConPat { pat_con_ext = noAnn , pat_con = s' - , pat_args = PrefixCon (map mkHsPatSigType ts') pps + , pat_args = PrefixCon (map (mkHsPatSigType noAnn) ts') pps } } cvtp (InfixP p1 s p2) = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2 @@ -1353,7 +1353,7 @@ cvtp (ListP ps) = do { ps' <- cvtPats ps ; return $ ListPat noAnn ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat noAnn p' (mkHsPatSigType t') } + ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noAnn e' p'} diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index b6f05c16d1..1d0fc14f87 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -597,3 +597,8 @@ Test19839: Test19840: $(CHECK_PPR) $(LIBDIR) Test19840.hs $(CHECK_EXACT) $(LIBDIR) Test19840.hs + +.PHONY: Test19850 +Test19850: + $(CHECK_PPR) $(LIBDIR) Test19850.hs + $(CHECK_EXACT) $(LIBDIR) Test19850.hs diff --git a/testsuite/tests/printer/Test19850.hs b/testsuite/tests/printer/Test19850.hs new file mode 100644 index 0000000000..38dc156103 --- /dev/null +++ b/testsuite/tests/printer/Test19850.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Test19850 where + +data Proxy (a :: k) = Proxy +data Con k (a :: k) = Con (Proxy a) + +tyApp :: Con k a -> Proxy a +tyApp (Con @kx @ax (x :: Proxy ax)) = x :: Proxy (ax :: kx) diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index b868427bfd..916ed6bbee 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -135,3 +135,4 @@ test('Test19821', ignore_stderr, makefile_test, ['Test19821']) test('Test19834', ignore_stderr, makefile_test, ['Test19834']) test('Test19839', ignore_stderr, makefile_test, ['Test19839']) test('Test19840', ignore_stderr, makefile_test, ['Test19840']) +test('Test19850', ignore_stderr, makefile_test, ['Test19850']) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index f63e9e61e1..fc11470069 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -3794,7 +3794,9 @@ instance ExactPrint (Pat GhcPs) where instance ExactPrint (HsPatSigType GhcPs) where getAnnotationEntry = const NoEntryVal - exact (HsPS _ ty) = markAnnotated ty + exact (HsPS an ty) = do + markAnnKw an id AnnAt + markAnnotated ty -- --------------------------------------------------------------------- diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 807ab7290b..4316f2bea0 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -189,7 +189,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/printer/Test19814.hs" Nothing -- "../../testsuite/tests/printer/Test19821.hs" Nothing -- "../../testsuite/tests/printer/Test19834.hs" Nothing - "../../testsuite/tests/printer/Test19840.hs" Nothing + -- "../../testsuite/tests/printer/Test19840.hs" Nothing + "../../testsuite/tests/printer/Test19850.hs" Nothing -- cloneT does not need a test, function can be retired -- cgit v1.2.1