From 3bc507db6906fc415aa0b91fec4b5feb8d3dd03c Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 22 Mar 2025 16:15:18 +0000
Subject: [PATCH] EPA: Fix exact printing of SPECIALISE pragma
This commit fixes two minor issues with exactprinting of the
SPECIALISE pragma after !12319 landed
- The span for the RHS did not include the optional signature type
- The `::` was printed twice when the legacy path was used
Closes #25885
---
compiler/GHC/Hs/Binds.hs | 2 +-
compiler/GHC/Parser.y | 14 +++---
compiler/GHC/Parser/PostProcess.hs | 9 ++--
testsuite/tests/printer/Makefile | 5 ++
testsuite/tests/printer/Test25885.hs | 70 ++++++++++++++++++++++++++++
testsuite/tests/printer/all.T | 3 +-
utils/check-exact/ExactPrint.hs | 3 +-
7 files changed, 91 insertions(+), 15 deletions(-)
create mode 100644 testsuite/tests/printer/Test25885.hs
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index cbe5f5b1a6e..3d69d5bc09f 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -724,7 +724,7 @@ data AnnSpecSig
= AnnSpecSig {
ass_open :: EpaLocation,
ass_close :: EpToken "#-}",
- ass_dcolon :: Maybe TokDcolon,
+ ass_dcolon :: Maybe TokDcolon, -- Only for old SpecSig, remove when it goes
ass_act :: ActivationAnn
} deriving Data
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index df002912ab4..8eb5d48fcb8 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2194,10 +2194,10 @@ sig_vars :: { Located [LocatedN RdrName] } -- Returned in reversed order
return (sLL $1 $> ($3 : h' : t)) }
| var { sL1 $1 [$1] }
-sigtypes1 :: { OrdList (LHsSigType GhcPs) }
- : sigtype { unitOL $1 }
+sigtypes1 :: { Located (OrdList (LHsSigType GhcPs)) }
+ : sigtype { sL1 $1 (unitOL $1) }
| sigtype ',' sigtypes1 {% do { st <- addTrailingCommaA $1 (epTok $2)
- ; return $ unitOL st `appOL` $3 } }
+ ; return $ sLL $1 $> (unitOL st `appOL` unLoc $3) } }
-----------------------------------------------------------------------------
-- Types
@@ -2781,7 +2781,7 @@ sigdecl :: { LHsDecl GhcPs }
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInlinePrag, FunLike)
(snd $2)
- spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) (fmap fst $5) (fst $2)) $3 $4 $5
+ spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) Nothing (fst $2)) $3 $4 $5
amsA' $ sLL $1 $> $ SigD noExtField spec }
| '{-# SPECIALISE_INLINE' activation rule_foralls infixexp sigtypes_maybe '#-}'
@@ -2789,7 +2789,7 @@ sigdecl :: { LHsDecl GhcPs }
let inl_prag = mkInlinePragma (getSPEC_INLINE_PRAGs $1)
(getSPEC_INLINE $1)
(snd $2)
- spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) (fmap fst $5) (fst $2)) $3 $4 $5
+ spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) Nothing (fst $2)) $3 $4 $5
amsA' $ sLL $1 $> $ SigD noExtField spec }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
@@ -2799,8 +2799,8 @@ sigdecl :: { LHsDecl GhcPs }
| '{-# MINIMAL' name_boolformula_opt '#-}'
{% amsA' (sLL $1 $> $ SigD noExtField (MinimalSig ((glR $1,epTok $3), (getMINIMAL_PRAGs $1)) $2)) }
-sigtypes_maybe :: { Maybe (TokDcolon, OrdList (LHsSigType GhcPs)) }
- : '::' sigtypes1 { Just (epUniTok $1, $2) }
+sigtypes_maybe :: { Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs))) }
+ : '::' sigtypes1 { Just (sLL $1 $> (epUniTok $1, unLoc $2)) }
| {- empty -} { Nothing }
activation :: { (ActivationAnn,Maybe Activation) }
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 8eb20a8b495..9b606578100 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1049,7 +1049,7 @@ mkSpecSig :: InlinePragma
-> AnnSpecSig
-> Maybe (RuleBndrs GhcPs)
-> LHsExpr GhcPs
- -> Maybe (TokDcolon, OrdList (LHsSigType GhcPs))
+ -> Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))
-> P (Sig GhcPs)
mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr
= case m_sigtypes_ascr of
@@ -1059,7 +1059,7 @@ mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr
SpecSigE activation_anns
(ruleBndrsOrDef m_rule_binds) expr inl_prag
- Just (colon_ann, sigtype_ol)
+ Just (L lt (colon_ann, sigtype_ol))
-- Singleton, e.g. {-# SPECIALISE f :: ty #-}
-- Use the SpecSigE route
@@ -1067,7 +1067,7 @@ mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr
-> pure $
SpecSigE activation_anns
(ruleBndrsOrDef m_rule_binds)
- (L (getLoc expr) -- ToDo: not really the right location for (e::ty)
+ (L ((combineSrcSpansA (getLoc expr) (noAnnSrcSpan lt)))
(ExprWithTySig colon_ann expr (mkHsWildCardBndrs sigtype)))
inl_prag
@@ -1077,7 +1077,8 @@ mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr
, L _ (HsVar _ var) <- expr
-> do addPsMessage sigs_loc PsWarnSpecMultipleTypeAscription
pure $
- SpecSig activation_anns var sigtype_list inl_prag
+ SpecSig (activation_anns {ass_dcolon = Just colon_ann })
+ var sigtype_list inl_prag
| otherwise ->
addFatalError $
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 4f3d023437a..4c2cb4eca87 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -896,3 +896,8 @@ Test25454:
Test25467:
$(CHECK_PPR) $(LIBDIR) Test25467.hs
$(CHECK_EXACT) $(LIBDIR) Test25467.hs
+
+.PHONY: Test25885
+Test25885:
+ $(CHECK_PPR) $(LIBDIR) Test25885.hs
+ $(CHECK_EXACT) $(LIBDIR) Test25885.hs
diff --git a/testsuite/tests/printer/Test25885.hs b/testsuite/tests/printer/Test25885.hs
new file mode 100644
index 00000000000..364a9defb29
--- /dev/null
+++ b/testsuite/tests/printer/Test25885.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GADTs, NamedWildCards, PartialTypeSignatures #-}
+module Test25885 where
+
+{-# SPECIALIZE bug :: Int -> Int #-}
+
+{-# SPECIALISE
+ showsIArray :: (Show i) => UA i -> String
+ #-}
+
+
+{-# SPECIALISE f1 :: Eq [e] => Word -> [e] -> Int #-}
+{-# SPECIALISE f1_qc :: ( forall y . Eq y => Eq ( g y ),
+ Eq ( g e ) ) => Proxy g -> g e -> Word -> Char #-}
+
+{-# SPECIALISE f2 :: Eq c => c -> c -> Word -> Int #-}
+
+{-# SPECIALISE f3 :: Eq c => [ c ] -> Bool #-}
+
+{-# SPECIALISE f3 :: ( forall y. Eq y => Eq ( g y ) ) => g Int -> Bool #-}
+{-# SPECIALISE f4 :: forall s b. Eq b => b -> ST s b #-}
+
+{-# SPECIALISE f4_qc :: forall r n b. (forall m. Monad m => Monad (r m)) => r n Int -> () #-}
+
+{-# SPECIALISE f5 :: D Int -> Bool #-}
+
+{-# SPECIALISE f5_qc :: D Int -> Bool #-}
+
+{-# SPECIALISE f5_qc :: ( forall y. ( Eq y, Eq ( T y ) ) => Eq ( g y ) ) => g Int -> Bool #-}
+{-# SPECIALISE f6 :: Ord c => c -> c -> Word -> Char #-}
+
+{-# SPECIALISE f6_qc :: ( forall z. Eq z => Ord ( h z ) ) => Proxy h -> Proxy h -> Word -> Char #-}
+
+{-# SPECIALISE f7 :: Cls Bool => Int -> Int #-}
+
+{-# SPECIALISE qcfd :: G () #-}
+
+------------------------------------------------------------------------
+
+{-# SPECIALISE INLINE op :: Example False -> Int #-}
+
+$( [d| baz :: Num a => a -> a
+ {-# SPECIALISE INLINE [~1] baz @Double #-}
+ baz x = x * 10 |] )
+
+{-# SPECIALISE foo @Int #-}
+
+{-# SPECIALISE foo @Float :: Float -> Float #-}
+
+{-# SPECIALISE foo (3 :: Int) #-}
+{-# SPECIALISE foo @Int 4 #-}
+
+
+{-# SPECIALISE INLINE foo @Double #-}
+
+{-# SPECIALISE bar @Float :: Float -> Int -> Float #-}
+
+{-# SPECIALISE bar @Double 3 :: Integer -> Double #-}
+
+{-# SPECIALISE [1] bar @_ @Int #-}
+
+{-# SPECIALISE bar @_a @_a #-}
+
+{-# SPECIALISE [~1] forall a. forall. baz @a @_ @a #-}
+
+
+{-# SPECIALISE tyEq :: Typeable c => Proxy c -> Proxy c -> Float #-}
+
+{-# SPECIALISE foo :: Float -> Float,
+ Double -> Double #-}
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 386e1ae1a44..35557bfed5e 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -214,4 +214,5 @@ test('Test25467', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25467'])
test('T24237', normal, compile_fail, [''])
-test('Test25454', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25454'])
\ No newline at end of file
+test('Test25454', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25454'])
+test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885'])
\ No newline at end of file
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index ca8537a9616..a3eb69ea844 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -2639,10 +2639,9 @@ instance ExactPrint (Sig GhcPs) where
o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
act' <- markActivation act (inl_act inl)
bndrs' <- markAnnotated bndrs
- dc' <- traverse markEpUniToken dc
expr' <- markAnnotated expr
c' <- markEpToken c
- return (SpecSigE (AnnSpecSig o' c' dc' act') bndrs' expr' inl)
+ return (SpecSigE (AnnSpecSig o' c' dc act') bndrs' expr' inl)
exact (SpecInstSig ((o,i,c),src) typ) = do
o' <- markAnnOpen'' o src "{-# SPECIALISE"
--
GitLab