Adriaan Leijnse pushed to branch wip/aidylns/RecConWildE at Glasgow Haskell Compiler / GHC Commits: aa05ad6f by Adriaan Leijnse at 2025-06-09T15:11:42+02:00 RecConWildE - - - - - 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: ===================================== compiler/GHC/Builtin/Names/TH.hs ===================================== @@ -60,7 +60,7 @@ templateHaskellNames = [ lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName, fromEName, fromThenEName, fromToEName, fromThenToEName, - listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, + listEName, sigEName, recConEName, recConWildEName, recUpdEName, staticEName, unboundVarEName, labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName, forallEName, forallVisEName, constrainedEName, -- FieldExp @@ -347,10 +347,11 @@ fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey fromToEName = libFun (fsLit "fromToE") fromToEIdKey fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey -- end ArithSeq -listEName, sigEName, recConEName, recUpdEName :: Name +listEName, sigEName, recConEName, recConWildEName, recUpdEName :: Name listEName = libFun (fsLit "listE") listEIdKey sigEName = libFun (fsLit "sigE") sigEIdKey recConEName = libFun (fsLit "recConE") recConEIdKey +recConWildEName = libFun (fsLit "recConWildE") recConWildEIdKey recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey staticEName = libFun (fsLit "staticE") staticEIdKey unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey @@ -892,7 +893,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey, - getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey, + getFieldEIdKey, projectionEIdKey, typeEIdKey, recConWildEIdKey, forallEIdKey, forallVisEIdKey, constrainedEIdKey :: Unique varEIdKey = mkPreludeMiscIdUnique 270 conEIdKey = mkPreludeMiscIdUnique 271 @@ -934,6 +935,7 @@ typeEIdKey = mkPreludeMiscIdUnique 306 forallEIdKey = mkPreludeMiscIdUnique 802 forallVisEIdKey = mkPreludeMiscIdUnique 803 constrainedEIdKey = mkPreludeMiscIdUnique 804 +recConWildEIdKey = mkPreludeMiscIdUnique 806 -- type FieldExp = ... fieldExpIdKey :: Unique ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1666,7 +1666,7 @@ repE (ExplicitSum _ alt arity e) repE (RecordCon { rcon_con = c, rcon_flds = flds }) = do { x <- lookupWithUserRdrLOcc c; fs <- repFields flds; - repRecCon x fs } + repRecCon x fs $ fmap (\(L _ (RecFieldsDotDot n)) -> n) $ rec_dotdot flds } repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } }) = do { x <- repLE e; fs <- repUpdFields flds; @@ -1833,7 +1833,7 @@ repLGRHS (L _ (GRHS _ ss rhs)) ; return (gs, guarded) } repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp]) -repFields (HsRecFields { rec_flds = flds }) +repFields (HsRecFields { rec_flds = flds }) -- The select on field names here caused a bug in TH after rec_dotdot was added. = repListM fieldExpTyConName rep_fld flds where rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) @@ -2580,8 +2580,14 @@ repListExp (MkC es) = rep2 listEName [es] repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] -repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp)) -repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] +repRecCon :: Core TH.Name -> Core [M TH.FieldExp] -> Maybe Int -> MetaM (Core (M TH.Exp)) +repRecCon (MkC c) (MkC fs) hasWildCard = + case hasWildCard of + { Nothing -> rep2 recConEName [c,fs] + ; Just n -> do + MkC n' <- coreIntLit n + rep2 recConWildEName [c,fs,n'] + } repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp)) repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1180,9 +1180,8 @@ cvtl e = wrapLA (cvt e) cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtSigType t ; let pe = parenthesizeHsExpr sigPrec e' ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') } - cvt (RecConE c flds) = do { c' <- cNameN c - ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds - ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn } + cvt (RecConE c flds) = thToHsRecCon c flds Nothing + cvt (RecConWildE c flds n) = thToHsRecCon c flds (Just (L noAnn (RecFieldsDotDot n))) cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) @@ -1226,6 +1225,11 @@ cvtl e = wrapLA (cvt e) mkHsForAllVisTele noAnn tvs' ; return $ HsForAll noExtField tele body' } +thToHsRecCon c flds maybeDotDot = do + { c' <- cNameN c + ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds + ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' maybeDotDot) noAnn } + {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: ===================================== libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs ===================================== @@ -231,8 +231,9 @@ pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e <+> dcolon <+> pprType sigPrec t -pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs) -pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) +pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields Nothing fs) +pprExp _ (RecConWildE nm fs n) = pprName' Applied nm <> braces (pprFields (Just n) fs) +pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields Nothing fs) -- FIXME: this can also have dots in surface syntax pprExp i (StaticE e) = parensIf (i >= appPrec) $ text "static"<+> pprExp appPrec e pprExp _ (UnboundVarE v) = pprName' Applied v @@ -250,8 +251,16 @@ pprExp i (ForallE tvars body) = pprExp i (ConstrainedE ctx body) = parensIf (i >= funPrec) $ sep [pprCtxWith pprExp ctx, pprExp qualPrec body] -pprFields :: [(Name,Exp)] -> Doc -pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e) +-- See Note [DotDot fields] in Language.Haskell.Syntax.Pat. +pprFields :: Maybe Int -> [(Name,Exp)] -> Doc +pprFields dotdot fs = + sep + . punctuate comma + . (case dotdot of + Nothing -> id + Just n -> (`mappend` [text ".."]) . take n) + . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e) + $ fs pprMaybeExp :: Precedence -> Maybe Exp -> Doc pprMaybeExp _ Nothing = empty ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs ===================================== @@ -378,6 +378,9 @@ sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) } recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) } +recConWildE :: Quote m => Name -> [m (Name,Exp)] -> Int -> m Exp +recConWildE c fs n = do { flds <- sequenceA fs; pure (RecConWildE c flds n) } + recUpdE :: Quote m => m Exp -> [m (Name,Exp)] -> m Exp recUpdE e fs = do { e1 <- e; flds <- sequenceA fs; pure (RecUpdE e1 flds) } ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -1885,6 +1885,11 @@ data Exp | ListE [ Exp ] -- ^ @{ [1,2,3] }@ | SigE Exp Type -- ^ @{ e :: t }@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ + -- Record constructor without a wild card. + | RecConWildE Name [FieldExp] Int -- ^ @{ T { x = y, z = w, ... } }@ + -- I.e. like `RecConE` but with a wild card. + -- See Note [DotDot fields] in Language.Haskell.Syntax.Pat + -- for the meaning of the Int parameter. | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ | StaticE Exp -- ^ @{ static e }@ | UnboundVarE Name -- ^ @{ _x }@ ===================================== testsuite/tests/th/T24537.hs ===================================== @@ -0,0 +1,16 @@ +{-# Language TemplateHaskell #-} +{-# Language RecordWildCards #-} +module Main where + +import Language.Haskell.TH.Ppr + +data G = H { field0 :: Int, field1 :: String } + +main :: IO () +main = do + let pr mq = do + q <- mq + print q + print . pprint $ q + pr [e|let field0 = 3 in H {field0,..}|] + pr [e|let { field0 = 3; field1 = "a" } in H {field0,..}|] ===================================== testsuite/tests/th/T24537.stdout ===================================== @@ -0,0 +1,4 @@ +LetE [ValD (VarP field0_0) (NormalB (LitE (IntegerL 3))) []] (RecConWildE Main.H [(Main.field0,VarE field0_0)] 1) +"let field0_0 = 3\n in Main.H{Main.field0 = field0_0, ..}" +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) +"let {field0_0 = 3; field1_1 = \"a\"}\n in Main.H{Main.field0 = field0_0, ..}" ===================================== testsuite/tests/th/all.T ===================================== @@ -637,3 +637,4 @@ test('T25083', [extra_files(['T25083_A.hs', 'T25083_B.hs'])], multimod_compile_a test('T25174', normal, compile, ['']) test('T25179', normal, compile, ['']) test('FunNameTH', normal, compile, ['']) +test('T24537', normal, compile_and_run, ['-v0 -ddump-splices -dsuppress-uniques']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa05ad6fef59aa57785eceb749672296... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa05ad6fef59aa57785eceb749672296... You're receiving this email because of your account on gitlab.haskell.org.