summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2022-05-03 10:38:28 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-05-06 19:22:58 -0400
commit0415449a6ef67ed8d6413683a3edabb23ff6ebe3 (patch)
tree94e27ec85fd3f807e515926ef8813c77cb329cc8
parente2ae9518c0373db7a99058a09388043a66af80ad (diff)
downloadhaskell-0415449a6ef67ed8d6413683a3edabb23ff6ebe3.tar.gz
template-haskell: Fix representation of OPAQUE pragmas
There is a mis-match between the TH representation of OPAQUE pragmas and GHC's internal representation due to how OPAQUE pragmas disallow phase annotations. It seemed most in keeping to just fix the wired in name issue by adding a special case to the desugaring of INLINE pragmas rather than making TH/GHC agree with how the representation should look. Fixes #21463
-rw-r--r--compiler/GHC/Builtin/Names/TH.hs14
-rw-r--r--compiler/GHC/HsToCore/Quote.hs16
-rw-r--r--testsuite/tests/th/T21463.hs10
-rw-r--r--testsuite/tests/th/all.T1
4 files changed, 33 insertions, 8 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index 98f8dacde0..2eb5e13530 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -71,7 +71,7 @@ templateHaskellNames = [
funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceWithOverlapDName,
standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
- pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
+ pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
dataInstDName, newtypeInstDName, tySynInstDName,
@@ -360,7 +360,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
- pragCompleteDName, implicitParamBindDName :: Name
+ pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey
@@ -375,6 +375,7 @@ defaultDName = libFun (fsLit "defaultD")
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
forImpDName = libFun (fsLit "forImpD") forImpDIdKey
pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
+pragOpaqueDName = libFun (fsLit "pragOpaqueD") pragOpaqueDIdKey
pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
@@ -595,11 +596,10 @@ quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
-- data Inline = ...
-noInlineDataConName, inlineDataConName, inlinableDataConName, opaqueDataConName :: Name
+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
-opaqueDataConName = thCon (fsLit "Opaque") opaqueDataConKey
-- data RuleMatch = ...
conLikeDataConName, funLikeDataConName :: Name
@@ -702,11 +702,10 @@ modNameTyConKey = mkPreludeTyConUnique 239
-- If you want to change this, make sure you check in GHC.Builtin.Names
-- data Inline = ...
-noInlineDataConKey, inlineDataConKey, inlinableDataConKey, opaqueDataConKey :: Unique
+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
noInlineDataConKey = mkPreludeDataConUnique 200
inlineDataConKey = mkPreludeDataConUnique 201
inlinableDataConKey = mkPreludeDataConUnique 202
-opaqueDataConKey = mkPreludeDataConUnique 203
-- data RuleMatch = ...
conLikeDataConKey, funLikeDataConKey :: Unique
@@ -888,7 +887,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
- kiSigDIdKey, defaultDIdKey :: Unique
+ kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -923,6 +922,7 @@ pragCompleteDIdKey = mkPreludeMiscIdUnique 350
implicitParamBindDIdKey = mkPreludeMiscIdUnique 351
kiSigDIdKey = mkPreludeMiscIdUnique 352
defaultDIdKey = mkPreludeMiscIdUnique 353
+pragOpaqueDIdKey = mkPreludeMiscIdUnique 354
-- type Cxt = ...
cxtIdKey :: Unique
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index ce986f7436..6718169bc3 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1084,6 +1084,13 @@ rep_inline :: LocatedN Name
-> SrcSpan
-> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_inline nm ispec loc
+ | Opaque {} <- inl_inline ispec
+ = do { nm1 <- lookupLOcc nm
+ ; opq <- repPragOpaque nm1
+ ; return [(loc, opq)]
+ }
+
+rep_inline nm ispec loc
= do { nm1 <- lookupLOcc nm
; inline <- repInline $ inl_inline ispec
; rm <- repRuleMatch $ inl_rule ispec
@@ -1118,7 +1125,11 @@ rep_specialiseInst ty loc
repInline :: InlineSpec -> MetaM (Core TH.Inline)
repInline (NoInline _ ) = dataCon noInlineDataConName
-repInline (Opaque _ ) = dataCon opaqueDataConName
+-- There is a mismatch between the TH and GHC representation because
+-- OPAQUE pragmas can't have phase activation annotations (which is
+-- enforced by the TH API), therefore they are desugared to OpaqueP rather than
+-- InlineP, see special case in rep_inline.
+repInline (Opaque _ ) = panic "repInline: Opaque"
repInline (Inline _ ) = dataCon inlineDataConName
repInline (Inlinable _ ) = dataCon inlinableDataConName
repInline NoUserInlinePrag = notHandled ThNoUserInline
@@ -2602,6 +2613,9 @@ repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
= rep2 pragInlDName [nm, inline, rm, phases]
+repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))
+repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]
+
repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
-> MetaM (Core (M TH.Dec))
repPragSpec (MkC nm) (MkC ty) (MkC phases)
diff --git a/testsuite/tests/th/T21463.hs b/testsuite/tests/th/T21463.hs
new file mode 100644
index 0000000000..bec226f72d
--- /dev/null
+++ b/testsuite/tests/th/T21463.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+main :: IO ()
+main = print
+ $([| let f :: Int -> Int
+ f x = x + 1
+ {-# OPAQUE f #-}
+ in f 41
+ |])
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 2a003b8141..ec79e19249 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -538,6 +538,7 @@ test('T20060', normal, compile, [''])
test('T20179', normal, compile_fail, [''])
test('T17820a', normal, compile_fail, [''])
test('T17820b', normal, compile_fail, [''])
+test('T21463', normal, compile, [''])
test('T17820c', normal, compile_fail, [''])
test('T17820d', normal, compile_fail, [''])
test('T17820e', normal, compile_fail, [''])