[Git][ghc/ghc][wip/int-index/emb-type] WIP: th support
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Thu Oct 27 19:34:46 UTC 2022
Vladislav Zavialov pushed to branch wip/int-index/emb-type at Glasgow Haskell Compiler / GHC
Commits:
a9969540 by Vladislav Zavialov at 2022-10-27T23:27:57+04:00
WIP: th support
- - - - -
14 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Quote.hs
- 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
- + testsuite/tests/vdq-rta/should_compile/T22326_th_dump1.hs
- + testsuite/tests/vdq-rta/should_compile/T22326_th_dump1.stderr
- + testsuite/tests/vdq-rta/should_compile/T22326_th_pprint1.hs
- + testsuite/tests/vdq-rta/should_compile/T22326_th_pprint1.stderr
- testsuite/tests/vdq-rta/should_compile/all.T
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -46,6 +46,7 @@ templateHaskellNames = [
litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
conPName, tildePName, bangPName, infixPName,
asPName, wildPName, recPName, listPName, sigPName, viewPName,
+ typePName,
-- FieldPat
fieldPatName,
-- Match
@@ -60,6 +61,7 @@ templateHaskellNames = [
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
labelEName, implicitParamVarEName, getFieldEName, projectionEName,
+ typeEName,
-- FieldExp
fieldExpName,
-- Body
@@ -255,7 +257,7 @@ charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey
-- data Pat = ...
litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
- sigPName, viewPName :: Name
+ sigPName, viewPName, typePName :: Name
litPName = libFun (fsLit "litP") litPIdKey
varPName = libFun (fsLit "varP") varPIdKey
tupPName = libFun (fsLit "tupP") tupPIdKey
@@ -271,6 +273,7 @@ recPName = libFun (fsLit "recP") recPIdKey
listPName = libFun (fsLit "listP") listPIdKey
sigPName = libFun (fsLit "sigP") sigPIdKey
viewPName = libFun (fsLit "viewP") viewPIdKey
+typePName = libFun (fsLit "typeP") typePIdKey
-- type FieldPat = ...
fieldPatName :: Name
@@ -289,7 +292,7 @@ varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,
unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
- labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name
+ labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey
@@ -330,6 +333,7 @@ labelEName = libFun (fsLit "labelE") labelEIdKey
implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
getFieldEName = libFun (fsLit "getFieldE") getFieldEIdKey
projectionEName = libFun (fsLit "projectionE") projectionEIdKey
+typeEName = libFun (fsLit "typeE") typeEIdKey
-- type FieldExp = ...
fieldExpName :: Name
@@ -781,7 +785,7 @@ liftStringIdKey = mkPreludeMiscIdUnique 230
-- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
- listPIdKey, sigPIdKey, viewPIdKey :: Unique
+ listPIdKey, sigPIdKey, viewPIdKey, typePIdKey :: Unique
litPIdKey = mkPreludeMiscIdUnique 240
varPIdKey = mkPreludeMiscIdUnique 241
tupPIdKey = mkPreludeMiscIdUnique 242
@@ -797,6 +801,7 @@ recPIdKey = mkPreludeMiscIdUnique 251
listPIdKey = mkPreludeMiscIdUnique 252
sigPIdKey = mkPreludeMiscIdUnique 253
viewPIdKey = mkPreludeMiscIdUnique 254
+typePIdKey = mkPreludeMiscIdUnique 255
-- type FieldPat = ...
fieldPatIdKey :: Unique
@@ -819,7 +824,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,
- getFieldEIdKey, projectionEIdKey :: Unique
+ getFieldEIdKey, projectionEIdKey, typeEIdKey :: Unique
varEIdKey = mkPreludeMiscIdUnique 270
conEIdKey = mkPreludeMiscIdUnique 271
litEIdKey = mkPreludeMiscIdUnique 272
@@ -856,28 +861,29 @@ implicitParamVarEIdKey = mkPreludeMiscIdUnique 302
mdoEIdKey = mkPreludeMiscIdUnique 303
getFieldEIdKey = mkPreludeMiscIdUnique 304
projectionEIdKey = mkPreludeMiscIdUnique 305
+typeEIdKey = mkPreludeMiscIdUnique 306
-- type FieldExp = ...
fieldExpIdKey :: Unique
-fieldExpIdKey = mkPreludeMiscIdUnique 306
+fieldExpIdKey = mkPreludeMiscIdUnique 307
-- data Body = ...
guardedBIdKey, normalBIdKey :: Unique
-guardedBIdKey = mkPreludeMiscIdUnique 307
-normalBIdKey = mkPreludeMiscIdUnique 308
+guardedBIdKey = mkPreludeMiscIdUnique 308
+normalBIdKey = mkPreludeMiscIdUnique 309
-- data Guard = ...
normalGEIdKey, patGEIdKey :: Unique
-normalGEIdKey = mkPreludeMiscIdUnique 309
-patGEIdKey = mkPreludeMiscIdUnique 310
+normalGEIdKey = mkPreludeMiscIdUnique 310
+patGEIdKey = mkPreludeMiscIdUnique 311
-- data Stmt = ...
bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
-bindSIdKey = mkPreludeMiscIdUnique 311
-letSIdKey = mkPreludeMiscIdUnique 312
-noBindSIdKey = mkPreludeMiscIdUnique 313
-parSIdKey = mkPreludeMiscIdUnique 314
-recSIdKey = mkPreludeMiscIdUnique 315
+bindSIdKey = mkPreludeMiscIdUnique 312
+letSIdKey = mkPreludeMiscIdUnique 313
+noBindSIdKey = mkPreludeMiscIdUnique 314
+parSIdKey = mkPreludeMiscIdUnique 315
+recSIdKey = mkPreludeMiscIdUnique 316
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -817,11 +817,11 @@ hsExprNeedsParens prec = go
go (HsUntypedBracket{}) = False
go (HsProc{}) = prec > topPrec
go (HsStatic{}) = prec >= appPrec
- go (HsEmbTy{}) = prec >= appPrec
go (RecordCon{}) = False
go (HsRecSel{}) = False
go (HsProjection{}) = True
go (HsGetField{}) = False
+ go (HsEmbTy{}) = prec > topPrec
go (XExpr x) = case ghcPass @p of
GhcTc -> go_x_tc x
GhcRn -> go_x_rn x
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -658,6 +658,7 @@ patNeedsParens p = go @p
= conPatNeedsParens p ds
go (SigPat {}) = p >= sigPrec
go (ViewPat {}) = True
+ go (EmbTyPat {}) = True
go (XPat ext) = case ghcPass @q of
#if __GLASGOW_HASKELL__ < 901
GhcPs -> dataConCantHappen ext
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1641,6 +1641,9 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
e1 <- repLE e
repGetField e1 f
repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
+repE (HsEmbTy _ _ t) = do
+ t1 <- repLTy (hswc_body t)
+ rep2 typeEName [unC t1]
repE (XExpr (HsExpanded orig_expr ds_expr))
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
@@ -2099,6 +2102,8 @@ repP p@(NPat _ (L _ l) (Just _) _)
repP (SigPat _ p t) = do { p' <- repLP p
; t' <- repLTy (hsPatSigType t)
; repPsig p' t' }
+repP (EmbTyPat _ _ t) = do { t' <- repLTy (hswc_body t)
+ ; repPtype t' }
repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n
repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p)
repP other = notHandled (ThExoticPattern other)
@@ -2344,6 +2349,9 @@ repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+repPtype :: Core (M TH.Type) -> MetaM (Core (M TH.Pat))
+repPtype (MkC t) = rep2 typePName [t]
+
--------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))
repVarOrCon vc str
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1099,6 +1099,8 @@ 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 (TypeE t) = do { t' <- cvtType t
+ ; return $ HsEmbTy noExtField noHsTok (mkHsWildCardBndrs t') }
{- | #16895 Ensure an infix expression's operator is a variable/constructor.
Consider this example:
@@ -1414,6 +1416,8 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat noAnn e' p'}
+cvtp (TypeP t) = do { t' <- cvtType t
+ ; return $ EmbTyPat noExtField noHsTok (mkHsWildCardBndrs t') }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib.hs
=====================================
@@ -33,7 +33,7 @@ module Language.Haskell.TH.Lib (
-- *** Patterns
litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP,
infixP, tildeP, bangP, asP, wildP, recP,
- listP, sigP, viewP,
+ listP, sigP, viewP, typeP,
fieldPat,
-- *** Pattern Guards
@@ -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, typeE,
-- **** Ranges
fromE, fromThenE, fromToE, fromThenToE,
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
=====================================
@@ -159,6 +159,9 @@ sigP :: Quote m => m Pat -> m Type -> m Pat
sigP p t = do p' <- p
t' <- t
pure (SigP p' t')
+typeP :: Quote m => m Type -> m Pat
+typeP t = do t' <- t
+ pure (TypeP t')
viewP :: Quote m => m Exp -> m Pat -> m Pat
viewP e p = do e' <- e
p' <- p
@@ -394,6 +397,8 @@ fromThenToE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
fromThenToE x y z = do { a <- x; b <- y; c <- z;
pure (ArithSeqE (FromThenToR a b c)) }
+typeE :: Quote m => m Type -> m Exp
+typeE = fmap TypeE
-------------------------------------------------------------------------------
-- * Dec
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -232,6 +232,7 @@ 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 i (TypeE t) = parensIf (i > noPrec) $ text "type" <+> ppr t
pprFields :: [(Name,Exp)] -> Doc
pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
@@ -382,6 +383,7 @@ pprPat _ (RecP nm fs)
pprPat _ (ListP ps) = brackets (commaSep ps)
pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t
pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
+pprPat _ (TypeP t) = parens $ text "type" <+> ppr t
------------------------------
instance Ppr Dec where
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -2256,6 +2256,7 @@ data Pat
| ListP [ Pat ] -- ^ @{ [1,2,3] }@
| SigP Pat Type -- ^ @{ p :: t }@
| ViewP Exp Pat -- ^ @{ e -> p }@
+ | TypeP Type -- ^ @{ type p }@
deriving( Show, Eq, Ord, Data, Generic )
type FieldPat = (Name,Pat)
@@ -2353,6 +2354,7 @@ data Exp
| ImplicitParamVarE String -- ^ @{ ?x }@ ( Implicit parameter )
| GetFieldE Exp String -- ^ @{ exp.field }@ ( Overloaded Record Dot )
| ProjectionE (NonEmpty String) -- ^ @(.x)@ or @(.x.y)@ (Record projections)
+ | TypeE Type -- ^ @{ type t }@
deriving( Show, Eq, Ord, Data, Generic )
type FieldExp = (Name,Exp)
=====================================
testsuite/tests/vdq-rta/should_compile/T22326_th_dump1.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE RequiredTypeArguments #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T22326_th_dump1 where
+
+$([d| f :: Integer -> forall a -> Num a => a
+ f n (type t) = fromInteger n :: t
+ |])
+
+$([d| x = 42 `f` (type Double)
+ n = f 42 (type Integer)
+ |])
\ No newline at end of file
=====================================
testsuite/tests/vdq-rta/should_compile/T22326_th_dump1.stderr
=====================================
@@ -0,0 +1,12 @@
+T22326_th_dump1.hs:(7,2)-(9,7): Splicing declarations
+ [d| f :: Integer -> forall a -> Num a => a
+ f n (type t) = fromInteger n :: t |]
+ ======>
+ f :: Integer -> forall a -> Num a => a
+ f n (type t) = fromInteger n :: t
+T22326_th_dump1.hs:(11,2)-(13,7): Splicing declarations
+ [d| x = 42 `f` (type Double)
+ n = f 42 (type Integer) |]
+ ======>
+ x = (42 `f` (type Double))
+ n = (f 42) (type Integer)
=====================================
testsuite/tests/vdq-rta/should_compile/T22326_th_pprint1.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE RequiredTypeArguments #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T22326_th_pprint1 where
+
+import System.IO
+import Language.Haskell.TH
+
+do decls <-
+ [d|
+ -- Definition:
+ f :: Integer -> forall a -> Num a => a
+ f n (type _) = fromInteger n
+
+ -- Usage:
+ x = 42 `f` (type Double)
+ n = f 42 (type Integer)
+ |]
+ runIO $ hPutStrLn stderr $ pprint decls
+ return []
=====================================
testsuite/tests/vdq-rta/should_compile/T22326_th_pprint1.stderr
=====================================
@@ -0,0 +1,5 @@
+f_0 :: GHC.Num.Integer.Integer ->
+ forall a_1 -> GHC.Num.Num a_1 => a_1
+f_0 n_2 (type _) = GHC.Num.fromInteger n_2
+x_3 = 42 `f_0` (type GHC.Types.Double)
+n_4 = f_0 42 (type GHC.Num.Integer.Integer)
=====================================
testsuite/tests/vdq-rta/should_compile/all.T
=====================================
@@ -1,6 +1,11 @@
+setTestOpts(normalise_version('base','ghc-prim'))
+
test('T22326_idv', normal, compile, [''])
test('T22326_typeRep', normal, compile, [''])
test('T22326_sizeOf', normal, compile, [''])
test('T22326_symbolVal', normal, compile, [''])
test('T17792_vdq', normal, compile, [''])
-test('T14158_vdq', normal, compile, [''])
\ No newline at end of file
+test('T14158_vdq', normal, compile, [''])
+
+test('T22326_th_dump1', req_th, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T22326_th_pprint1', req_th, compile, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a996954002285fa5b09986b4a8b387180d0f39ad
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a996954002285fa5b09986b4a8b387180d0f39ad
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/20221027/ae224948/attachment-0001.html>
More information about the ghc-commits
mailing list