Support OpaqueP

The `OPAQUE` pragma was introduced in GHC 9.4.

Addresses one part of #157.

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

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.

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

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

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
              ]
 

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
              ]