Support more embedded types in terms (GHC 9.12)

This adds `DForallE` and `DConstrainedE` constructors to `DExp`, mirroring
similar changes on the `template-haskell` side in GHC 9.12.

Checks off one box in #221.

.github/workflows/haskell-ci.yml

@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.19.20240512
+# version: 0.19.20241021
 #
-# REGENDATA ("0.19.20240512",["--config=cabal.haskell-ci","cabal.project"])
+# REGENDATA ("0.19.20241021",["--config=cabal.haskell-ci","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -28,6 +28,11 @@ jobs:
     strategy:
       matrix:
         include:
+          - compiler: ghc-9.12.20241014
+            compilerKind: ghc
+            compilerVersion: 9.12.20241014
+            setup-method: ghcup
+            allow-failure: false
           - compiler: ghc-9.10.1
             compilerKind: ghc
             compilerVersion: 9.10.1
@@ -38,9 +43,9 @@ jobs:
             compilerVersion: 9.8.2
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.6.4
+          - compiler: ghc-9.6.6
             compilerKind: ghc
-            compilerVersion: 9.6.4
+            compilerVersion: 9.6.6
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.4.8
@@ -95,10 +100,11 @@ jobs:
           apt-get update
           apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev
           mkdir -p "$HOME/.ghcup/bin"
-          curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup"
           chmod a+x "$HOME/.ghcup/bin/ghcup"
+          "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml;
           "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
-          "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -116,12 +122,12 @@ jobs:
           echo "HC=$HC" >> "$GITHUB_ENV"
           echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
           echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
-          echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
           echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
-          if [ $((HCNUMVER >= 91000)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
+          if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
           echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
           echo "GHCJSARITH=0" >> "$GITHUB_ENV"
         env:
@@ -216,7 +222,7 @@ jobs:
           if $HEADHACKAGE; then
           echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project
           fi
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(th-desugar)$/; }' >> cabal.project.local
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(th-desugar)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local
       - name: dump install plan

CHANGES.md

@@ -3,6 +3,11 @@
 
 Version 1.18 [????.??.??]
 -------------------------
+* Support GHC 9.12.
+* Add further support for embedded types in terms. The `DExp` type now has a
+  `DForallE` data constructor (mirroring `ForallE` and `ForallVisE` in
+  `template-haskell`) and a `DConstrainedE` data constructor (mirroring
+  `ConstrainedE` in `template-haskell`).
 * The `DLamE` and `DCaseE` data constructors (as well as the related
   `mkDLamEFromDPats` function) are now deprecated in favor of the new
   `DLamCasesE` data constructor. `DLamE`, `DCaseE`, and `mkDLamEFromDPats` will

Language/Haskell/TH/Desugar/AST.hs

@@ -54,6 +54,8 @@ data DExp = DVarE Name
           | DTypedBracketE DExp
           | DTypedSpliceE DExp
           | DTypeE DType
+          | DForallE DForallTelescope DExp
+          | DConstrainedE [DExp] DExp
           deriving (Eq, Show, Data, Generic, Lift)
 
 -- | A 'DLamCasesE' value with exactly one 'DClause' where all 'DPat's are

Language/Haskell/TH/Desugar/Core.hs

@@ -255,6 +255,14 @@ dsExp (TypedSpliceE exp)  = DTypedSpliceE <$> dsExp exp
 #if __GLASGOW_HASKELL__ >= 909
 dsExp (TypeE ty) = DTypeE <$> dsType ty
 #endif
+#if __GLASGOW_HASKELL__ >= 911
+dsExp (ForallE tvbs exp) =
+  DForallE <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsExp exp
+dsExp (ForallVisE tvbs exp) =
+  DForallE <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsExp exp
+dsExp (ConstrainedE preds exp) =
+  DConstrainedE <$> mapM dsExp preds <*> dsExp exp
+#endif
 
 #if __GLASGOW_HASKELL__ >= 809
 dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp

Language/Haskell/TH/Desugar/Match.hs

@@ -56,6 +56,8 @@ scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty
 scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty
 scExp (DTypedBracketE exp) = DTypedBracketE <$> scExp exp
 scExp (DTypedSpliceE exp) = DTypedSpliceE <$> scExp exp
+scExp (DForallE tele exp) = DForallE tele <$> scExp exp
+scExp (DConstrainedE cxt exp) = DConstrainedE <$> mapM scExp cxt <*> scExp exp
 scExp e@(DVarE {}) = return e
 scExp e@(DConE {}) = return e
 scExp e@(DLitE {}) = return e

Language/Haskell/TH/Desugar/Sweeten.hs

@@ -134,6 +134,20 @@ expToTH (DTypeE ty)          = TypeE (typeToTH ty)
 expToTH (DTypeE {})          =
   error "Embedded type expressions supported only in GHC 9.10+"
 #endif
+#if __GLASGOW_HASKELL__ >= 911
+expToTH (DForallE tele exp)  =
+  case tele of
+    DForallInvis tvbs -> ForallE    (map tvbToTH tvbs) exp'
+    DForallVis   tvbs -> ForallVisE (map tvbToTH tvbs) exp'
+  where
+    exp' = expToTH exp
+expToTH (DConstrainedE cxt exp) = ConstrainedE (map expToTH cxt) (expToTH exp)
+#else
+expToTH (DForallE {})        =
+  error "Embedded `forall`s supported only in GHC 9.12+"
+expToTH (DConstrainedE {})   =
+  error "Embedded constraints supported only in GHC 9.12+"
+#endif
 
 matchToTH :: DMatch -> Match
 matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []

Test/Run.hs

@@ -42,6 +42,10 @@ [email protected]
 {-# LANGUAGE RequiredTypeArguments #-}
 #endif
 
+#if __GLASGOW_HASKELL__ >= 911
+{-# LANGUAGE ImpredicativeTypes #-}
+#endif
+
 module Main where
 
 import Prelude hiding ( exp )
@@ -202,6 +206,11 @@ tests = test [ "sections" ~: $test1_sections  @=? $(dsSplice test1_sections)
              , "embedded_types_cases_no_keyword" ~: $test67_embedded_types_cases_no_keyword @=? $(dsSplice test67_embedded_types_cases_no_keyword)
              , "invis_type_pat_lambda" ~: $test68_invis_type_pat_lambda @=? $(dsSplice test68_invis_type_pat_lambda)
              , "invis_type_pat_cases" ~: $test69_invis_type_pat_cases @=? $(dsSplice test69_invis_type_pat_cases)
+#endif
+#if __GLASGOW_HASKELL__ >= 911
+             , "embedded_forall_invis" ~: $(test70_embedded_forall_invis) @=? $(dsSplice test70_embedded_forall_invis)
+             , "embedded_forall_vis" ~: $(test71_embedded_forall_vis) @=? $(dsSplice test71_embedded_forall_vis)
+             , "embedded_constraint" ~: $(test72_embedded_constraint) @=? $(dsSplice test72_embedded_constraint)
 #endif
              ]
 

Test/Splices.hs

@@ -464,6 +464,23 @@ test69_invis_type_pat_cases =
   [| aux (\cases @a (x :: a) -> x :: a) @Bool True |]
 #endif
 
+#if __GLASGOW_HASKELL__ >= 911
+test70_embedded_forall_invis =
+  [| let idv :: forall a -> a -> a
+         idv _ x = x
+     in idv (forall a. a -> a) id True |]
+
+test71_embedded_forall_vis =
+  [| let idv :: forall a -> a -> a
+         idv _ x = x
+     in idv (forall a -> a -> a) idv Bool True |]
+
+test72_embedded_constraint =
+  [| let idv :: forall a -> a -> a
+         idv _ x = x
+     in idv (forall a. (a ~ Bool) => a -> a) (\x -> not x) False |]
+#endif
+
 type family TFExpand x
 type instance TFExpand Int = Bool
 type instance TFExpand (Maybe a) = [a]
@@ -941,5 +958,10 @@ test_exprs = [ test1_sections
              , test67_embedded_types_cases_no_keyword
              , test68_invis_type_pat_lambda
              , test69_invis_type_pat_cases
+#endif
+#if __GLASGOW_HASKELL__ >= 911
+             , test70_embedded_forall_invis
+             , test71_embedded_forall_vis
+             , test72_embedded_constraint
 #endif
              ]

th-desugar.cabal

@@ -21,9 +21,10 @@ tested-with:    GHC == 8.0.2
               , GHC == 9.0.2
               , GHC == 9.2.8
               , GHC == 9.4.8
-              , GHC == 9.6.4
+              , GHC == 9.6.6
               , GHC == 9.8.2
               , GHC == 9.10.1
+              , GHC == 9.12.1
 description:
     This package provides the Language.Haskell.TH.Desugar module, which desugars
     Template Haskell's rich encoding of Haskell syntax into a simpler encoding.