Draft: Support more embedded types in terms

TODO RGS: Cite T221
goldfirere · Aug 2, 2024 · 3b9c037 · 3b9c037
1 parent b60b71f
commit 3b9c037
Show file tree

Hide file tree

Showing 7 changed files with 63 additions and 0 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -4,6 +4,10 @@
 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

diff --git a/Language/Haskell/TH/Desugar/AST.hs b/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

diff --git a/Language/Haskell/TH/Desugar/Core.hs b/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

diff --git a/Language/Haskell/TH/Desugar/Match.hs b/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

diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs
@@ -134,6 +134,22 @@ 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 invisible `forall`s supported only in GHC 9.12+"
+expToTH (DForallVisE {})     =
+  error "Embedded visible `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)) []

diff --git a/Test/Run.hs b/Test/Run.hs
@@ -42,6 +42,10 @@ rae@cs.brynmawr.edu
 {-# 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
              ]
 

diff --git a/Test/Splices.hs b/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
              ]