[Git][ghc/ghc][master] Allow generation of TTH syntax with TH

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Wed Apr 12 16:33:14 UTC 2023



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00
Allow generation of TTH syntax with TH

In other words allow generation of typed splices and brackets with
Untyped Template Haskell.

That is useful in cases where a library is build with TTH in mind,
but we still want to generate some auxiliary declarations,
where TTH cannot help us, but untyped TH can.
Such example is e.g. `staged-sop` which works with TTH,
but we would like to derive `Generic` declarations with TH.

An alternative approach is to use `unsafeCodeCoerce`, but then the
derived `Generic` instances would be type-checked only at use sites,
i.e. much later. Also `-ddump-splices` output is quite ugly:
user-written instances would use TTH brackets, not `unsafeCodeCoerce`.

This commit doesn't allow generating of untyped template splices
and brackets with untyped TH, as I don't know why one would want to do
that (instead of merging the splices, e.g.)

- - - - -


17 changed files:

- compiler/GHC/ThToHs.hs
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- + testsuite/tests/th/TH_typed1.hs
- + testsuite/tests/th/TH_typed1.stdout
- + testsuite/tests/th/TH_typed2.hs
- + testsuite/tests/th/TH_typed2.stdout
- + testsuite/tests/th/TH_typed3.hs
- + testsuite/tests/th/TH_typed3.stderr
- + testsuite/tests/th/TH_typed4.hs
- + testsuite/tests/th/TH_typed4.stderr
- + testsuite/tests/th/TH_typed5.hs
- + testsuite/tests/th/TH_typed5.stdout
- testsuite/tests/th/all.T


Changes:

=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1157,6 +1157,10 @@ cvtl e = wrapLA (cvt e)
                                          (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
     cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap
                                          (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString  . fsLit) xs
+    cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e
+                              ; return $ HsTypedSplice (noAnn, noAnn) e' }
+    cvt (TypedBracketE e) = do { e' <- cvtl e
+                               ; return $ HsTypedBracket noAnn e' }
 
 {- | #16895 Ensure an infix expression's operator is a variable/constructor.
 Consider this example:


=====================================
libraries/template-haskell/Language/Haskell/TH/Lib.hs
=====================================
@@ -44,7 +44,7 @@ module Language.Haskell.TH.Lib (
         appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,
         lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE,
         multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE,
-        fieldExp, getFieldE, projectionE,
+        fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE,
     -- **** Ranges
     fromE, fromThenE, fromToE, fromThenToE,
 


=====================================
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
=====================================
@@ -380,6 +380,12 @@ getFieldE e f = do
 projectionE :: Quote m => NonEmpty String -> m Exp
 projectionE xs = pure (ProjectionE xs)
 
+typedSpliceE :: Quote m => m Exp -> m Exp
+typedSpliceE = fmap TypedSpliceE
+
+typedBracketE :: Quote m => m Exp -> m Exp
+typedBracketE = fmap TypedBracketE
+
 -- ** 'arithSeqE' Shortcuts
 fromE :: Quote m => m Exp -> m Exp
 fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }


=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -232,6 +232,8 @@ pprExp _ (LabelE s) = text "#" <> text s
 pprExp _ (ImplicitParamVarE n) = text ('?' : n)
 pprExp _ (GetFieldE e f) = pprExp appPrec e <> text ('.': f)
 pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) $ toList xs
+pprExp _ (TypedBracketE e) = text "[||" <> ppr e <> text "||]"
+pprExp _ (TypedSpliceE e) = text "$$" <> pprExp appPrec e
 
 pprFields :: [(Name,Exp)] -> Doc
 pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)


=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -2385,6 +2385,8 @@ data Exp
   | ImplicitParamVarE String           -- ^ @{ ?x }@ ( Implicit parameter )
   | GetFieldE Exp String               -- ^ @{ exp.field }@ ( Overloaded Record Dot )
   | ProjectionE (NonEmpty String)      -- ^ @(.x)@ or @(.x.y)@ (Record projections)
+  | TypedBracketE Exp                  -- ^ @[|| e ||]@
+  | TypedSpliceE Exp                   -- ^ @$$e@
   deriving( Show, Eq, Ord, Data, Generic )
 
 type FieldExp = (Name,Exp)


=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -8,6 +8,10 @@
 
     This change enables TemplateHaskell support for `DuplicateRecordFields`.
 
+  * Add support for generating typed splices and brackets in untyped Template Haskell
+    Introduces `typedSpliceE :: Quote m => m Exp -> m Exp` and
+    `typedBracketE :: Quote m => m Exp -> m Exp`
+
 ## 2.20.0.0
 
   * The `Ppr.pprInfixT` function has gained a `Precedence` argument. 


=====================================
testsuite/tests/th/TH_typed1.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main = print $$( $(typedBracketE [| 'x' |]) )


=====================================
testsuite/tests/th/TH_typed1.stdout
=====================================
@@ -0,0 +1 @@
+'x'


=====================================
testsuite/tests/th/TH_typed2.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main = print $( typedSpliceE $ typedBracketE [| 'y' |] )


=====================================
testsuite/tests/th/TH_typed2.stdout
=====================================
@@ -0,0 +1 @@
+'y'


=====================================
testsuite/tests/th/TH_typed3.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+-- test parenthesis around splice
+main = do
+    print $( typedSpliceE $ typedBracketE [| 'z' |] )
+    print $( typedSpliceE $ appE [| id |] (typedBracketE [| 'z' |]) )


=====================================
testsuite/tests/th/TH_typed3.stderr
=====================================
@@ -0,0 +1,9 @@
+TH_typed3.hs:9:12-53: Splicing expression
+    typedSpliceE $ typedBracketE [| 'z' |] ======> $$[|| 'z' ||]
+TH_typed3.hs:10:12-69: Splicing expression
+    typedSpliceE $ appE [| id |] (typedBracketE [| 'z' |])
+  ======>
+    $$(id [|| 'z' ||])
+TH_typed3.hs:9:12-53: Splicing expression [|| 'z' ||] ======> 'z'
+TH_typed3.hs:10:12-69: Splicing expression
+    id [|| 'z' ||] ======> 'z'


=====================================
testsuite/tests/th/TH_typed4.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main = print $$( $$(unsafeCodeCoerce $ typedBracketE $ litE $ charL 'a' :: Code Q (Code Q Char)) )


=====================================
testsuite/tests/th/TH_typed4.stderr
=====================================
@@ -0,0 +1,10 @@
+TH_typed4.hs:7:20-96: Splicing expression
+      unsafeCodeCoerce $ typedBracketE $ litE $ charL 'a' ::
+        Code Q (Code Q Char)
+  ======>
+    [|| 'a' ||]
+TH_typed4.hs:7:16-98: Splicing expression
+    $$(unsafeCodeCoerce $ typedBracketE $ litE $ charL 'a' ::
+         Code Q (Code Q Char))
+  ======>
+    'a'


=====================================
testsuite/tests/th/TH_typed5.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Ppr
+
+main = do
+    putStrLn =<< fmap pprint (typedSpliceE $ typedBracketE [| 'z' |])
+    putStrLn =<< fmap pprint (typedSpliceE $ appE [| id |] (typedBracketE [| 'z' |]))


=====================================
testsuite/tests/th/TH_typed5.stdout
=====================================
@@ -0,0 +1,2 @@
+$$[||'z'||]
+$$(GHC.Base.id [||'z'||])


=====================================
testsuite/tests/th/all.T
=====================================
@@ -559,3 +559,8 @@ test('T22819', normal, compile, ['-v0'])
 test('TH_fun_par', normal, compile, [''])
 test('T23036', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T23203', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_typed1', normal, compile_and_run, [''])
+test('TH_typed2', normal, compile_and_run, [''])
+test('TH_typed3', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_typed4', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_typed5', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ebd8918b7c50ae51921664e24fac0de4376ffcf9

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ebd8918b7c50ae51921664e24fac0de4376ffcf9
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230412/a9f56c39/attachment-0001.html>


More information about the ghc-commits mailing list