summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2021-05-16 14:58:45 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-05-23 02:07:36 -0400
commit406cd90b8863da640a9835d5d9972fff1c18dcd7 (patch)
tree7b287e1ce76efbbe9910734d4f4b5d7952815251
parent0b1eed74e8ad5194152ed656ac3e4a547726b70a (diff)
downloadhaskell-406cd90b8863da640a9835d5d9972fff1c18dcd7.tar.gz
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
-rw-r--r--compiler/GHC/Hs/Type.hs8
-rw-r--r--compiler/GHC/Parser/PostProcess.hs11
-rw-r--r--compiler/GHC/Parser/Types.hs4
-rw-r--r--compiler/GHC/ThToHs.hs6
-rw-r--r--testsuite/tests/printer/Makefile5
-rw-r--r--testsuite/tests/printer/Test19850.hs14
-rw-r--r--testsuite/tests/printer/all.T1
-rw-r--r--utils/check-exact/ExactPrint.hs4
-rw-r--r--utils/check-exact/Main.hs3
9 files changed, 41 insertions, 15 deletions
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 8bcc508288..b4e53efeb6 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