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 ]