diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index b01a4705ec029d740b48a6f720257e21ea9651f0..0ea14689274bade5b91e30779e9aea08afee2834 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -76,7 +76,8 @@ templateHaskellNames = [
classDName, instanceWithOverlapDName,
standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
- pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,
+ pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
+ defaultSigDName, defaultDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
dataInstDName, newtypeInstDName, tySynInstDName,
infixLDName, infixRDName, infixNDName,
@@ -374,7 +375,8 @@ recSName = libFun (fsLit "recS") recSIdKey
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
- pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
+ pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
+ standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
@@ -401,6 +403,8 @@ pragSpecInstDName = libFun (fsLit "pragSpecInstD")
pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey
pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey
+pragSCCFunDName = libFun (fsLit "pragSCCFunD") pragSCCFunDKey
+pragSCCFunNamedDName = libFun (fsLit "pragSCCFunNamedD") pragSCCFunNamedDKey
dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
@@ -921,7 +925,8 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
- kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique
+ kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey,
+ pragSCCFunDKey, pragSCCFunNamedDKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -958,6 +963,8 @@ kiSigDIdKey = mkPreludeMiscIdUnique 352
defaultDIdKey = mkPreludeMiscIdUnique 353
pragOpaqueDIdKey = mkPreludeMiscIdUnique 354
typeDataDIdKey = mkPreludeMiscIdUnique 355
+pragSCCFunDKey = mkPreludeMiscIdUnique 356
+pragSCCFunNamedDKey = mkPreludeMiscIdUnique 357
-- type Cxt = ...
cxtIdKey :: Unique
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 0d5a5950aca29abae8e3bb5b2a034eeddc62a615..04ebe88af69359312a9769f4e0f67f84ea8a05e4 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -997,7 +997,7 @@ rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
-rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas
+rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc)
rep_sig (L loc (CompleteMatchSig _ cls mty))
= rep_complete_sig cls mty (locA loc)
rep_sig d@(L _ (XSig {})) = pprPanic "rep_sig IdSig" (ppr d)
@@ -1121,6 +1121,21 @@ rep_specialiseInst ty loc
; pragma <- repPragSpecInst ty1
; return [(loc, pragma)] }
+rep_sccFun :: LocatedN Name
+ -> Maybe (XRec GhcRn StringLiteral)
+ -> SrcSpan
+ -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_sccFun nm Nothing loc = do
+ nm1 <- lookupLOcc nm
+ scc <- repPragSCCFun nm1
+ return [(loc, scc)]
+
+rep_sccFun nm (Just (L _ str)) loc = do
+ nm1 <- lookupLOcc nm
+ str1 <- coreStringLit (sl_fs str)
+ scc <- repPragSCCFunNamed nm1 str1
+ return [(loc, scc)]
+
repInline :: InlineSpec -> MetaM (Core TH.Inline)
repInline (NoInline _ ) = dataCon noInlineDataConName
-- There is a mismatch between the TH and GHC representation because
@@ -2687,6 +2702,12 @@ repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phas
repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
+repPragSCCFun :: Core TH.Name -> MetaM (Core (M TH.Dec))
+repPragSCCFun (MkC nm) = rep2 pragSCCFunDName [nm]
+
+repPragSCCFunNamed :: Core TH.Name -> Core String -> MetaM (Core (M TH.Dec))
+repPragSCCFunNamed (MkC nm) (MkC str) = rep2 pragSCCFunNamedDName [nm, str]
+
repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
repTySynInst (MkC eqn)
= rep2 tySynInstDName [eqn]
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 2fe751300b008b2be5b907c3e8fd355ea4840dbb..10f1c6c846de9a47c58bd2f790dcbb55d3710649 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -954,6 +954,12 @@ cvtPragmaD (CompleteP cls mty)
; mty' <- traverse tconNameN mty
; returnJustLA $ Hs.SigD noExtField
$ CompleteMatchSig (noAnn, NoSourceText) cls' mty' }
+cvtPragmaD (SCCP nm str) = do
+ nm' <- vcNameN nm
+ str' <- traverse (\s ->
+ returnLA $ StringLiteral NoSourceText (mkFastString s) Nothing) str
+ returnJustLA $ Hs.SigD noExtField
+ $ SCCFunSig (noAnn, SourceText $ fsLit "{-# SCC") nm' str'
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 4da31ac144dd896d24b79d579b1275bea7d5374c..66192bdceda1eed91bfc5bf7afc370b8ddd677d8 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -553,6 +553,12 @@ pragLineD line file = pure $ PragmaD $ LineP line file
pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec
pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty
+pragSCCFunD :: Quote m => Name -> m Dec
+pragSCCFunD nm = pure $ PragmaD $ SCCP nm Nothing
+
+pragSCCFunNamedD :: Quote m => Name -> String -> m Dec
+pragSCCFunNamedD nm str = pure $ PragmaD $ SCCP nm (Just str)
+
dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con]
-> [m DerivClause] -> m Dec
dataInstD ctxt mb_bndrs ty ksig cons derivs =
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 65be9831770dab78bbfba6750d7d1df54fee2177..9f138fdf916d02049583fe2a8b361508cab952c4 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -658,6 +658,8 @@ instance Ppr Pragma where
ppr (CompleteP cls mty)
= text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)
<+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"
+ ppr (SCCP nm str)
+ = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty text str <+> text "#-}"
------------------------------
instance Ppr Inline where
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 95f1b7fa171c38f78505e6a869c94fdc54ee024f..1e3859949fe2b46cd504f9ad2575d59c20b1d853 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2629,6 +2629,8 @@ data Pragma = InlineP Name Inline RuleMatch Phases
| LineP Int String
| CompleteP [Name] (Maybe Name)
-- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@
+ | SCCP Name (Maybe String)
+ -- ^ @{ {\-\# SCC fun "optional_name" \#-} }@
deriving( Show, Eq, Ord, Data, Generic )
data Inline = NoInline
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 0efa706750fa6e457bf4baf861e0123ab332047a..9c33cb7971fba2d5e970be1a67d20263cd4448b6 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -8,6 +8,8 @@
* Extend `Pat` with `TypeP` and `Exp` with `TypeE`,
introduce functions `typeP` and `typeE` (GHC Proposal #281).
+ * Extend `Pragma` with `SCCP`.
+
## 2.21.0.0
* Record fields now belong to separate `NameSpace`s, keyed by the parent of
diff --git a/testsuite/tests/th/should_compile/T24081/Main.hs b/testsuite/tests/th/should_compile/T24081/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a92589ef2df445a7c0550120404c0d646c609d02
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T24081/Main.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import TH
+
+x
+y
+a = 1
+b = 1
+gen
+
+main = return ()
diff --git a/testsuite/tests/th/should_compile/T24081/Makefile b/testsuite/tests/th/should_compile/T24081/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..1c39d1c1fed04f14cab76d17579c1e97343590f0
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T24081/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/th/should_compile/T24081/T24081.stderr b/testsuite/tests/th/should_compile/T24081/T24081.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..b39eec7244b9d50bb1d0ad1d5d58cfc03d962c66
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T24081/T24081.stderr
@@ -0,0 +1,15 @@
+Main.hs:5:1: Splicing declarations
+ x
+ ======>
+ {-# SCC f #-}
+ f = 1
+Main.hs:6:1: Splicing declarations
+ y
+ ======>
+ {-# SCC g custom_name_g #-}
+ g = 1
+Main.hs:9:1-3: Splicing declarations
+ gen
+ ======>
+ {-# SCC a #-}
+ {-# SCC b custom_name_b #-}
diff --git a/testsuite/tests/th/should_compile/T24081/TH.hs b/testsuite/tests/th/should_compile/T24081/TH.hs
new file mode 100644
index 0000000000000000000000000000000000000000..95c8120854ced83e39edc1e2ca2aa9d8a541ea19
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T24081/TH.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH where
+
+import Data.Maybe
+import Language.Haskell.TH
+
+x, y :: Q [Dec]
+x = [d|{-# SCC f #-}; f = 1|]
+y = [d|{-# SCC g "custom_name_g" #-}; g = 1|]
+
+gen :: Q [Dec]
+gen = do
+ a <- fromJust <$> lookupValueName "a"
+ b <- fromJust <$> lookupValueName "b"
+ pure
+ [ PragmaD $ SCCP a Nothing
+ , PragmaD $ SCCP b (Just "custom_name_b")
+ ]
diff --git a/testsuite/tests/th/should_compile/T24081/all.T b/testsuite/tests/th/should_compile/T24081/all.T
new file mode 100644
index 0000000000000000000000000000000000000000..87da13cd0f4925c247989e45192416283e578aaa
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T24081/all.T
@@ -0,0 +1,2 @@
+test('T24081', [extra_files(['TH.hs', 'Main.hs']), req_th],
+ multimod_compile, ['TH Main', '-v0 -ddump-splices -dsuppress-uniques'])