[Git][ghc/ghc][master] 2 commits: Allow SCC declarations in TH (#24081)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jan 10 22:37:58 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7a808419 by Xiaoyan Ren at 2024-01-10T17:37:24-05:00
Allow SCC declarations in TH (#24081)
- - - - -
28827c51 by Xiaoyan Ren at 2024-01-10T17:37:24-05:00
Fix prettyprinting of SCC pragmas
- - - - -
13 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/SourceText.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- + testsuite/tests/th/should_compile/T24081/Main.hs
- + testsuite/tests/th/should_compile/T24081/Makefile
- + testsuite/tests/th/should_compile/T24081/T24081.stderr
- + testsuite/tests/th/should_compile/T24081/TH.hs
- + testsuite/tests/th/should_compile/T24081/all.T
Changes:
=====================================
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
=====================================
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]
=====================================
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
=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -322,4 +322,4 @@ instance Eq StringLiteral where
(StringLiteral _ a _) == (StringLiteral _ b _) = a == b
instance Outputable StringLiteral where
- ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
+ ppr sl = pprWithSourceText (sl_st sl) (doubleQuotes $ ftext $ sl_fs sl)
=====================================
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 =
=====================================
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 pprString str <+> text "#-}"
------------------------------
instance Ppr Inline where
=====================================
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
=====================================
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
=====================================
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 ()
=====================================
testsuite/tests/th/should_compile/T24081/Makefile
=====================================
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
=====================================
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" #-}
=====================================
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")
+ ]
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/08d14925bd58521def3a892cc9acbb82764eccaa...28827c513ea5020f03accc72aeb2168dbfd49b91
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/08d14925bd58521def3a892cc9acbb82764eccaa...28827c513ea5020f03accc72aeb2168dbfd49b91
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240110/bf36e712/attachment-0001.html>
More information about the ghc-commits
mailing list