Support TH constructs added in GHC 9.4

CHANGES.md

@@ -3,12 +3,24 @@
 
 Version 1.14 [????.??.??]
 -------------------------
+* Support GHC 9.4.
 * Drop support for GHC 7.8 and 7.10. As a consequence of this, the
   `strictToBang` was removed as it no longer serves a useful purpose.
 * Desugared lambda expressions and guards that bind multiple patterns can now
   have patterns with unlifted types. The desugared code uses `UnboxedTuples` to
   make this possible, so if you load the desugared code into GHCi on prior to
   GHC 9.2, you will need to enable `-fobject-code`.
+* `th-desugar` now desugars `PromotedInfixT` and `PromotedUInfixT`, which were
+  added in GHC 9.4. Mirroring the existing treatment of other `Promoted*`
+  `Type`s, `PromotedInfixT` is desugared to an application of a `DConT` applied
+  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) and
+  `OpaqueP` (i.e., `OPAQUE` pragmas), which were added in GHC 9.4.
+* `th-desugar` now desugars `LamCasesE` (i.e., `\cases` expressions), which was
+  added in GHC 9.4. A `\cases` expression is desugared to an ordinary lambda
+  expression, much like `\case` is currently desugared.
 * 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

@@ -135,6 +135,7 @@ data DDec = DLetDec DLetDec
           | DKiSigD Name DKind
               -- DKiSigD is part of DDec, not DLetDec, because standalone kind
               -- signatures can only appear on the top level.
+          | DDefaultD [DType]
           deriving (Eq, Show, Data, Generic)
 
 -- | Corresponds to TH's 'PatSynDir' type
@@ -254,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

@@ -247,6 +247,35 @@ dsExp (ProjectionE fields) =
     comp :: DExp -> String -> DExp
     comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc
 #endif
+#if __GLASGOW_HASKELL__ >= 903
+dsExp (LamCasesE clauses) = do
+  clauses' <- dsClauses CaseAlt clauses
+  numArgs <-
+    case clauses' of
+      (DClause pats _:_) -> return $ length pats
+      [] -> fail "\\cases expression must have at least one alternative"
+  args <- replicateM numArgs (newUniqueName "x")
+  return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args))
+                               (map dClauseToUnboxedTupleMatch clauses')
+#endif
+
+-- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns
+-- into a match on a single unboxed tuple pattern. That is, convert this:
+--
+-- @
+-- f x y z = rhs
+-- @
+--
+-- To this:
+--
+-- @
+-- f (# x, y, z #) = rhs
+-- @
+--
+-- This is used to desugar @\\cases@ expressions into lambda expressions.
+dClauseToUnboxedTupleMatch :: DClause -> DMatch
+dClauseToUnboxedTupleMatch (DClause pats rhs) =
+  DMatch (mkUnboxedTupleDPat pats) rhs
 
 #if __GLASGOW_HASKELL__ >= 809
 dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp
@@ -737,6 +766,9 @@ dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param bindi
 #if __GLASGOW_HASKELL__ >= 809
 dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki)
 #endif
+#if __GLASGOW_HASKELL__ >= 903
+dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)
+#endif
 
 -- | Desugar a 'DataD' or 'NewtypeD'.
 dsDataDec :: DsMonad q
@@ -841,7 +873,7 @@ dsLetDecs decs = do
 -- 'DLetDec's to support parallel assignment of implicit params.
 dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)
 dsLetDec (FunD name clauses) = do
-  clauses' <- dsClauses name clauses
+  clauses' <- dsClauses (FunRhs name) clauses
   return ([DFunD name clauses'], id)
 dsLetDec (ValD pat body where_decs) = do
   (pat', vars) <- dsPatX pat
@@ -1011,6 +1043,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
@@ -1036,19 +1071,19 @@ dsTySynEqn n (TySynEqn lhss rhs) = do
 
 -- | Desugar clauses to a function definition
 dsClauses :: DsMonad q
-          => Name         -- ^ Name of the function
+          => MatchContext -- ^ The context in which the clauses arise
           -> [Clause]     -- ^ Clauses to desugar
           -> q [DClause]
 dsClauses _ [] = return []
-dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do
+dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do
   -- this case is necessary to maintain the roundtrip property.
-  rest' <- dsClauses n rest
+  rest' <- dsClauses mc rest
   exp' <- dsExp exp
   (where_decs', ip_binder) <- dsLetDecs where_decs
   let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp')
   (pats', exp'') <- dsPatsOverExp pats exp_with_wheres
   return $ DClause pats' exp'' : rest'
-dsClauses n clauses@(Clause outer_pats _ _ : _) = do
+dsClauses mc clauses@(Clause outer_pats _ _ : _) = do
   arg_names <- replicateM (length outer_pats) (newUniqueName "arg")
   let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)
   clause <- DClause (map DVarP arg_names) <$>
@@ -1057,8 +1092,7 @@ dsClauses n clauses@(Clause outer_pats _ _ : _) = do
   where
     clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]
     clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do
-      let failure_exp = maybeDCaseE (FunRhs n)
-                                    scrutinee failure_matches
+      let failure_exp = maybeDCaseE mc scrutinee failure_matches
       exp <- dsBody body where_decs failure_exp
       (pats', exp') <- dsPatsOverExp pats exp
       uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats'
@@ -1128,8 +1162,8 @@ dsType StarT = return $ DConT typeKindName
 dsType ConstraintT = return $ DConT ''Constraint
 dsType (LitT lit) = return $ DLitT lit
 dsType EqualityT = return $ DConT ''(~)
-dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2
-dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."
+dsType (InfixT t1 n t2) = dsInfixT t1 n t2
+dsType (UInfixT{}) = dsUInfixT
 dsType (ParensT t) = dsType t
 dsType WildCardT = return DWildCardT
 #if __GLASGOW_HASKELL__ >= 801
@@ -1145,6 +1179,10 @@ dsType (ImplicitParamT n t) = do
 dsType (ForallVisT tvbs ty) =
   DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty
 #endif
+#if __GLASGOW_HASKELL__ >= 903
+dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2
+dsType PromotedUInfixT{} = dsUInfixT
+#endif
 
 #if __GLASGOW_HASKELL__ >= 900
 -- | Desugar a 'TyVarBndr'.
@@ -1192,6 +1230,14 @@ types, we pretend as if MulArrowT does not exist. As a result, the type of
 `Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.
 -}
 
+-- | Desugar an infix 'Type'.
+dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType
+dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2
+
+-- | We cannot desugar unresolved infix operators, so fail if we encounter one.
+dsUInfixT :: Fail.MonadFail m => m a
+dsUInfixT = fail "Cannot desugar unresolved infix operators."
+
 -- | Desugar a 'TyVarBndrSpec'.
 dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec
 #if __GLASGOW_HASKELL__ >= 900
@@ -1245,7 +1291,7 @@ dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty
 dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir
 dsPatSynDir _ Unidir              = pure DUnidir
 dsPatSynDir _ ImplBidir           = pure DImplBidir
-dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses n clauses
+dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses
 #endif
 
 -- | Desugar a @Pred@, flattening any internal tuples
@@ -1283,8 +1329,8 @@ dsPred ConstraintT =
 dsPred t@(LitT _) =
   impossible $ "Type literal seen as head of constraint: " ++ show t
 dsPred EqualityT = return [DConT ''(~)]
-dsPred (InfixT t1 n t2) = (:[]) <$> (DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2)
-dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."
+dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2
+dsPred (UInfixT{}) = dsUInfixT
 dsPred (ParensT t) = dsPred t
 dsPred WildCardT = return [DWildCardT]
 #if __GLASGOW_HASKELL__ >= 801
@@ -1306,6 +1352,10 @@ dsPred t@(ForallVisT {}) =
 #if __GLASGOW_HASKELL__ >= 900
 dsPred MulArrowT = impossible "Linear arrow seen as head of constraint."
 #endif
+#if __GLASGOW_HASKELL__ >= 903
+dsPred (PromotedInfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2
+dsPred PromotedUInfixT{} = dsUInfixT
+#endif
 
 -- | Desugar a quantified constraint.
 dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt

Language/Haskell/TH/Desugar/Sweeten.hs

@@ -140,6 +140,12 @@ decToTH (DKiSigD n ki) = KiSigD n (typeToTH ki)
 decToTH (DKiSigD {})   =
   error "Standalone kind signatures supported only in GHC 8.10+"
 #endif
+#if __GLASGOW_HASKELL__ >= 903
+decToTH (DDefaultD tys) = DefaultD (map typeToTH tys)
+#else
+decToTH (DDefaultD{})   =
+  error "Default declarations supported only in GHC 9.4+"
+#endif
 
 #if __GLASGOW_HASKELL__ < 801
 patSynErr :: a
@@ -244,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,10 @@ 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)
+             , "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases)
 #endif
              ]
 

Test/Splices.hs

@@ -339,6 +339,18 @@ 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!" |]
+
+test56_lambda_cases =
+  [| (\cases (Just x) (Just y) -> x ++ y
+             _        _        -> "") (Just "Hello") (Just "World") |]
+#endif
+
 type family TFExpand x
 type instance TFExpand Int = Bool
 type instance TFExpand (Maybe a) = [a]
@@ -758,5 +770,9 @@ test_exprs = [ test1_sections
 #endif
 #if __GLASGOW_HASKELL__ >= 902
              , test54_overloaded_record_dot
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+             , test55_opaque_pragma
+             , test56_lambda_cases
 #endif
              ]