From c25a32af7d0c252ea9b7db8719a06577bc80650b Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Sat, 30 Apr 2022 11:07:48 -0400
Subject: [PATCH] Support OpaqueP

The `OPAQUE` pragma was introduced in GHC 9.4.

Addresses one part of #157.
---
 CHANGES.md                             |  3 ++-
 Language/Haskell/TH/Desugar/AST.hs     |  1 +
 Language/Haskell/TH/Desugar/Core.hs    |  3 +++
 Language/Haskell/TH/Desugar/Sweeten.hs |  5 +++++
 Test/Run.hs                            |  3 +++
 Test/Splices.hs                        | 11 +++++++++++
 6 files changed, 25 insertions(+), 1 deletion(-)

diff --git a/CHANGES.md b/CHANGES.md
index b3c9790..cbbf0ce 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -16,7 +16,8 @@ Version 1.14 [????.??.??]
   to two arguments, just like `InfixT` is desugared. Similarly, attempting to
   desugar a `PromotedUInfixT` results in an error, just like attempting to
   desugar a `UInfixT` would be.
-* `th-desugar` now supports `DefaultD` (i.e., `default` declarations).
+* `th-desugar` now supports `DefaultD` (i.e., `default` declarations) and
+  `OpaqueP` (i.e., `OPAQUE` pragmas), which were added in GHC 9.4.
 * Fix an inconsistency which caused non-exhaustive `case` expressions to be
   desugared into uses of `EmptyCase`. Non-exhaustive `case` expressions are now
   desugared into code that throws a "`Non-exhaustive patterns in...`" error at
diff --git a/Language/Haskell/TH/Desugar/AST.hs b/Language/Haskell/TH/Desugar/AST.hs
index d300c46..b425390 100644
--- a/Language/Haskell/TH/Desugar/AST.hs
+++ b/Language/Haskell/TH/Desugar/AST.hs
@@ -255,6 +255,7 @@ data DPragma = DInlineP Name Inline RuleMatch Phases
              | DAnnP AnnTarget DExp
              | DLineP Int String
              | DCompleteP [Name] (Maybe Name)
+             | DOpaqueP Name
              deriving (Eq, Show, Data, Generic)
 
 -- | Corresponds to TH's @RuleBndr@ type.
diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs
index ec30db5..6d8f41f 100644
--- a/Language/Haskell/TH/Desugar/Core.hs
+++ b/Language/Haskell/TH/Desugar/Core.hs
@@ -1012,6 +1012,9 @@ dsPragma (LineP n str)                   = return $ DLineP n str
 #if __GLASGOW_HASKELL__ >= 801
 dsPragma (CompleteP cls mty)             = return $ DCompleteP cls mty
 #endif
+#if __GLASGOW_HASKELL__ >= 903
+dsPragma (OpaqueP n)                     = return $ DOpaqueP n
+#endif
 
 -- | Desugar a @RuleBndr@.
 dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs
index 1c52666..d4a77e9 100644
--- a/Language/Haskell/TH/Desugar/Sweeten.hs
+++ b/Language/Haskell/TH/Desugar/Sweeten.hs
@@ -250,6 +250,11 @@ pragmaToTH (DCompleteP {}) = error "COMPLETE pragmas only supported in GHC 8.2+"
 #else
 pragmaToTH (DCompleteP cls mty) = CompleteP cls mty
 #endif
+#if __GLASGOW_HASKELL__ >= 903
+pragmaToTH (DOpaqueP n) = OpaqueP n
+#else
+pragmaToTH (DOpaqueP {}) = error "OPAQUE pragmas only supported in GHC 9.4+"
+#endif
 
 ruleBndrToTH :: DRuleBndr -> RuleBndr
 ruleBndrToTH (DRuleVar n) = RuleVar n
diff --git a/Test/Run.hs b/Test/Run.hs
index f72f948..dd46fa4 100644
--- a/Test/Run.hs
+++ b/Test/Run.hs
@@ -146,6 +146,9 @@ tests = test [ "sections" ~: $test1_sections  @=? $(dsSplice test1_sections)
 #endif
 #if __GLASGOW_HASKELL__ >= 902
              , "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot)
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+             , "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma)
 #endif
              ]
 
diff --git a/Test/Splices.hs b/Test/Splices.hs
index bb81453..8c94694 100644
--- a/Test/Splices.hs
+++ b/Test/Splices.hs
@@ -339,6 +339,14 @@ test54_overloaded_record_dot =
      in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |]
 #endif
 
+#if __GLASGOW_HASKELL__ >= 903
+test55_opaque_pragma =
+  [| let f :: String -> String
+         f x = x
+         {-# OPAQUE f #-}
+     in f "Hello, World!" |]
+#endif
+
 type family TFExpand x
 type instance TFExpand Int = Bool
 type instance TFExpand (Maybe a) = [a]
@@ -758,5 +766,8 @@ test_exprs = [ test1_sections
 #endif
 #if __GLASGOW_HASKELL__ >= 902
              , test54_overloaded_record_dot
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+             , test55_opaque_pragma
 #endif
              ]