Support PromotedInfixT and PromotedUInfixT

We desugar `PromotedInfixT` to applications of `DConT` to two arguments,
mirroring the existing treatment for `InfixT`. By a similar token, attempting
to desugar `PromotedUInfixT` results in an error, just like what would happen
if you attempt to desugar `UInfixT` today.

Addresses one part of #157.

CHANGES.md

@@ -3,12 +3,19 @@
 
 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.
 * 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/Core.hs

@@ -1128,8 +1128,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 +1145,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 +1196,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
@@ -1283,8 +1295,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 +1318,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