From 3b9c037260824a39f2be8b5f731a46e2426b37c7 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 2 Aug 2024 06:02:02 -0400 Subject: [PATCH] Draft: Support more embedded types in terms TODO RGS: Cite T221 --- CHANGES.md | 4 ++++ Language/Haskell/TH/Desugar/AST.hs | 2 ++ Language/Haskell/TH/Desugar/Core.hs | 8 ++++++++ Language/Haskell/TH/Desugar/Match.hs | 2 ++ Language/Haskell/TH/Desugar/Sweeten.hs | 16 ++++++++++++++++ Test/Run.hs | 9 +++++++++ Test/Splices.hs | 22 ++++++++++++++++++++++ 7 files changed, 63 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 37e4a20..63b894b 100644 --- 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 index c9a5f1d..83dff9d 100644 --- 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 index ed0bc3f..de8ff92 100644 --- 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 index 9140a49..698f9f2 100644 --- 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 index ba2d5e0..7bcd821 100644 --- 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 index eac9c86..e1a13f2 100644 --- 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 index 3fa25f3..e18deb3 100644 --- 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 ]