Adriaan Leijnse pushed to branch wip/aidylns/RecConWildE at Glasgow Haskell Compiler / GHC
Commits:
-
7411211a
by Adriaan Leijnse at 2025-06-09T15:06:48+02:00
9 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/ThToHs.hs
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- + testsuite/tests/th/T24537.hs
- + testsuite/tests/th/T24537.stdout
- testsuite/tests/th/all.T
Changes:
| ... | ... | @@ -60,7 +60,7 @@ templateHaskellNames = [ |
| 60 | 60 | lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,
|
| 61 | 61 | condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
|
| 62 | 62 | fromEName, fromThenEName, fromToEName, fromThenToEName,
|
| 63 | - listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
|
|
| 63 | + listEName, sigEName, recConEName, recConWildEName, recUpdEName, staticEName, unboundVarEName,
|
|
| 64 | 64 | labelEName, implicitParamVarEName, getFieldEName, projectionEName,
|
| 65 | 65 | typeEName, forallEName, forallVisEName, constrainedEName,
|
| 66 | 66 | -- FieldExp
|
| ... | ... | @@ -347,10 +347,11 @@ fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey |
| 347 | 347 | fromToEName = libFun (fsLit "fromToE") fromToEIdKey
|
| 348 | 348 | fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
|
| 349 | 349 | -- end ArithSeq
|
| 350 | -listEName, sigEName, recConEName, recUpdEName :: Name
|
|
| 350 | +listEName, sigEName, recConEName, recConWildEName, recUpdEName :: Name
|
|
| 351 | 351 | listEName = libFun (fsLit "listE") listEIdKey
|
| 352 | 352 | sigEName = libFun (fsLit "sigE") sigEIdKey
|
| 353 | 353 | recConEName = libFun (fsLit "recConE") recConEIdKey
|
| 354 | +recConWildEName = libFun (fsLit "recConWildE") recConWildEIdKey
|
|
| 354 | 355 | recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
|
| 355 | 356 | staticEName = libFun (fsLit "staticE") staticEIdKey
|
| 356 | 357 | unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
|
| ... | ... | @@ -892,7 +893,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, |
| 892 | 893 | fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
|
| 893 | 894 | listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
|
| 894 | 895 | unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,
|
| 895 | - getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey,
|
|
| 896 | + getFieldEIdKey, projectionEIdKey, typeEIdKey, recConWildEIdKey, forallEIdKey,
|
|
| 896 | 897 | forallVisEIdKey, constrainedEIdKey :: Unique
|
| 897 | 898 | varEIdKey = mkPreludeMiscIdUnique 270
|
| 898 | 899 | conEIdKey = mkPreludeMiscIdUnique 271
|
| ... | ... | @@ -934,6 +935,7 @@ typeEIdKey = mkPreludeMiscIdUnique 306 |
| 934 | 935 | forallEIdKey = mkPreludeMiscIdUnique 802
|
| 935 | 936 | forallVisEIdKey = mkPreludeMiscIdUnique 803
|
| 936 | 937 | constrainedEIdKey = mkPreludeMiscIdUnique 804
|
| 938 | +recConWildEIdKey = mkPreludeMiscIdUnique 805
|
|
| 937 | 939 | |
| 938 | 940 | -- type FieldExp = ...
|
| 939 | 941 | fieldExpIdKey :: Unique
|
| ... | ... | @@ -1666,7 +1666,7 @@ repE (ExplicitSum _ alt arity e) |
| 1666 | 1666 | repE (RecordCon { rcon_con = c, rcon_flds = flds })
|
| 1667 | 1667 | = do { x <- lookupWithUserRdrLOcc c;
|
| 1668 | 1668 | fs <- repFields flds;
|
| 1669 | - repRecCon x fs }
|
|
| 1669 | + repRecCon x fs $ fmap (\(L _ (RecFieldsDotDot n)) -> n) $ rec_dotdot flds }
|
|
| 1670 | 1670 | repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } })
|
| 1671 | 1671 | = do { x <- repLE e;
|
| 1672 | 1672 | fs <- repUpdFields flds;
|
| ... | ... | @@ -1833,7 +1833,7 @@ repLGRHS (L _ (GRHS _ ss rhs)) |
| 1833 | 1833 | ; return (gs, guarded) }
|
| 1834 | 1834 | |
| 1835 | 1835 | repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
|
| 1836 | -repFields (HsRecFields { rec_flds = flds })
|
|
| 1836 | +repFields (HsRecFields { rec_flds = flds }) -- The select on field names here caused a bug in TH after rec_dotdot was added.
|
|
| 1837 | 1837 | = repListM fieldExpTyConName rep_fld flds
|
| 1838 | 1838 | where
|
| 1839 | 1839 | rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
|
| ... | ... | @@ -2580,8 +2580,14 @@ repListExp (MkC es) = rep2 listEName [es] |
| 2580 | 2580 | repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
|
| 2581 | 2581 | repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
|
| 2582 | 2582 | |
| 2583 | -repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))
|
|
| 2584 | -repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
|
|
| 2583 | +repRecCon :: Core TH.Name -> Core [M TH.FieldExp] -> Maybe Int -> MetaM (Core (M TH.Exp))
|
|
| 2584 | +repRecCon (MkC c) (MkC fs) hasWildCard =
|
|
| 2585 | + case hasWildCard of
|
|
| 2586 | + { Nothing -> rep2 recConEName [c,fs]
|
|
| 2587 | + ; Just n -> do
|
|
| 2588 | + MkC n' <- coreIntLit n
|
|
| 2589 | + rep2 recConWildEName [c,fs,n']
|
|
| 2590 | + }
|
|
| 2585 | 2591 | |
| 2586 | 2592 | repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))
|
| 2587 | 2593 | repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
|
| ... | ... | @@ -1180,9 +1180,8 @@ cvtl e = wrapLA (cvt e) |
| 1180 | 1180 | cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtSigType t
|
| 1181 | 1181 | ; let pe = parenthesizeHsExpr sigPrec e'
|
| 1182 | 1182 | ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }
|
| 1183 | - cvt (RecConE c flds) = do { c' <- cNameN c
|
|
| 1184 | - ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds
|
|
| 1185 | - ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn }
|
|
| 1183 | + cvt (RecConE c flds) = thToHsRecCon c flds Nothing
|
|
| 1184 | + cvt (RecConWildE c flds n) = thToHsRecCon c flds (Just (L noAnn (RecFieldsDotDot n)))
|
|
| 1186 | 1185 | cvt (RecUpdE e flds) = do { e' <- cvtl e
|
| 1187 | 1186 | ; flds'
|
| 1188 | 1187 | <- mapM (cvtFld (wrapParLA mkFieldOcc))
|
| ... | ... | @@ -1226,6 +1225,11 @@ cvtl e = wrapLA (cvt e) |
| 1226 | 1225 | mkHsForAllVisTele noAnn tvs'
|
| 1227 | 1226 | ; return $ HsForAll noExtField tele body' }
|
| 1228 | 1227 | |
| 1228 | +thToHsRecCon c flds maybeDotDot = do
|
|
| 1229 | + { c' <- cNameN c
|
|
| 1230 | + ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds
|
|
| 1231 | + ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' maybeDotDot) noAnn }
|
|
| 1232 | + |
|
| 1229 | 1233 | {- | #16895 Ensure an infix expression's operator is a variable/constructor.
|
| 1230 | 1234 | Consider this example:
|
| 1231 | 1235 |
| ... | ... | @@ -231,8 +231,9 @@ pprExp _ (ArithSeqE d) = ppr d |
| 231 | 231 | pprExp _ (ListE es) = brackets (commaSep es)
|
| 232 | 232 | pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
|
| 233 | 233 | <+> dcolon <+> pprType sigPrec t
|
| 234 | -pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)
|
|
| 235 | -pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
|
|
| 234 | +pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields Nothing fs)
|
|
| 235 | +pprExp _ (RecConWildE nm fs n) = pprName' Applied nm <> braces (pprFields (Just n) fs)
|
|
| 236 | +pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields Nothing fs) -- FIXME: this can also have dots in surface syntax
|
|
| 236 | 237 | pprExp i (StaticE e) = parensIf (i >= appPrec) $
|
| 237 | 238 | text "static"<+> pprExp appPrec e
|
| 238 | 239 | pprExp _ (UnboundVarE v) = pprName' Applied v
|
| ... | ... | @@ -250,8 +251,16 @@ pprExp i (ForallE tvars body) = |
| 250 | 251 | pprExp i (ConstrainedE ctx body) =
|
| 251 | 252 | parensIf (i >= funPrec) $ sep [pprCtxWith pprExp ctx, pprExp qualPrec body]
|
| 252 | 253 | |
| 253 | -pprFields :: [(Name,Exp)] -> Doc
|
|
| 254 | -pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
|
|
| 254 | +-- See Note [DotDot fields] in Language.Haskell.Syntax.Pat.
|
|
| 255 | +pprFields :: Maybe Int -> [(Name,Exp)] -> Doc
|
|
| 256 | +pprFields dotdot fs =
|
|
| 257 | + sep
|
|
| 258 | + . punctuate comma
|
|
| 259 | + . (case dotdot of
|
|
| 260 | + Nothing -> id
|
|
| 261 | + Just n -> (`mappend` [text ".."]) . take n)
|
|
| 262 | + . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
|
|
| 263 | + $ fs
|
|
| 255 | 264 | |
| 256 | 265 | pprMaybeExp :: Precedence -> Maybe Exp -> Doc
|
| 257 | 266 | pprMaybeExp _ Nothing = empty
|
| ... | ... | @@ -378,6 +378,9 @@ sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) } |
| 378 | 378 | recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp
|
| 379 | 379 | recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) }
|
| 380 | 380 | |
| 381 | +recConWildE :: Quote m => Name -> [m (Name,Exp)] -> Int -> m Exp
|
|
| 382 | +recConWildE c fs n = do { flds <- sequenceA fs; pure (RecConWildE c flds n) }
|
|
| 383 | + |
|
| 381 | 384 | recUpdE :: Quote m => m Exp -> [m (Name,Exp)] -> m Exp
|
| 382 | 385 | recUpdE e fs = do { e1 <- e; flds <- sequenceA fs; pure (RecUpdE e1 flds) }
|
| 383 | 386 |
| ... | ... | @@ -1885,6 +1885,11 @@ data Exp |
| 1885 | 1885 | | ListE [ Exp ] -- ^ @{ [1,2,3] }@
|
| 1886 | 1886 | | SigE Exp Type -- ^ @{ e :: t }@
|
| 1887 | 1887 | | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@
|
| 1888 | + -- Record constructor without a wild card.
|
|
| 1889 | + | RecConWildE Name [FieldExp] Int -- ^ @{ T { x = y, z = w, ... } }@
|
|
| 1890 | + -- I.e. like `RecConE` but with a wild card.
|
|
| 1891 | + -- See Note [DotDot fields] in Language.Haskell.Syntax.Pat
|
|
| 1892 | + -- for the meaning of the Int parameter.
|
|
| 1888 | 1893 | | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@
|
| 1889 | 1894 | | StaticE Exp -- ^ @{ static e }@
|
| 1890 | 1895 | | UnboundVarE Name -- ^ @{ _x }@
|
| 1 | +{-# Language TemplateHaskell #-}
|
|
| 2 | +{-# Language RecordWildCards #-}
|
|
| 3 | +module Main where
|
|
| 4 | + |
|
| 5 | +import Language.Haskell.TH.Ppr
|
|
| 6 | + |
|
| 7 | +data G = H { field0 :: Int, field1 :: String }
|
|
| 8 | + |
|
| 9 | +main :: IO ()
|
|
| 10 | +main = do
|
|
| 11 | + let pr mq = do
|
|
| 12 | + q <- mq
|
|
| 13 | + print q
|
|
| 14 | + print . pprint $ q
|
|
| 15 | + pr [e|let field0 = 3 in H {field0,..}|]
|
|
| 16 | + pr [e|let { field0 = 3; field1 = "a" } in H {field0,..}|] |
| 1 | +LetE [ValD (VarP field0_0) (NormalB (LitE (IntegerL 3))) []] (RecConWildE Main.H [(Main.field0,VarE field0_0)] 1)
|
|
| 2 | +"let field0_0 = 3\n in Main.H{Main.field0 = field0_0, ..}"
|
|
| 3 | +LetE [ValD (VarP field0_2) (NormalB (LitE (IntegerL 3))) [],ValD (VarP field1_1) (NormalB (LitE (StringL "a"))) []] (RecConWildE Main.H [(Main.field0,VarE field0_2),(Main.field1,VarE field1_1)] 1)
|
|
| 4 | +"let {field0_0 = 3; field1_1 = \"a\"}\n in Main.H{Main.field0 = field0_0, ..}" |
| ... | ... | @@ -637,3 +637,4 @@ test('T25083', [extra_files(['T25083_A.hs', 'T25083_B.hs'])], multimod_compile_a |
| 637 | 637 | test('T25174', normal, compile, [''])
|
| 638 | 638 | test('T25179', normal, compile, [''])
|
| 639 | 639 | test('FunNameTH', normal, compile, [''])
|
| 640 | +test('T24537', normal, compile_and_run, ['-v0 -ddump-splices -dsuppress-uniques']) |