template-haskell: Fix representation of OPAQUE pragmaswip/backport-MR8133

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

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, [''])