diff options
66 files changed, 1552 insertions, 75 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 6f9aec86cb..93ea664739 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -332,6 +332,9 @@ basicKnownKeyNames fromListNName, toListName, + -- Overloaded record dot, record update + getFieldName, setFieldName, + -- List operations concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, @@ -1527,6 +1530,11 @@ fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey +-- HasField class ops +getFieldName, setFieldName :: Name +getFieldName = varQual gHC_RECORDS (fsLit "getField") getFieldClassOpKey +setFieldName = varQual gHC_RECORDS (fsLit "setField") setFieldClassOpKey + -- Class Show showClassName :: Name showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey @@ -2548,6 +2556,10 @@ unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 +-- HasField class ops +getFieldClassOpKey, setFieldClassOpKey :: Unique +getFieldClassOpKey = mkPreludeMiscIdUnique 572 +setFieldClassOpKey = mkPreludeMiscIdUnique 573 ------------------------------------------------------ -- ghc-bignum uses 600-699 uniques diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index e0ef09eba8..3633edf48c 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3554,6 +3554,8 @@ xFlagsDeps = [ flagSpec "Rank2Types" LangExt.RankNTypes, flagSpec "RankNTypes" LangExt.RankNTypes, flagSpec "RebindableSyntax" LangExt.RebindableSyntax, + flagSpec "OverloadedRecordDot" LangExt.OverloadedRecordDot, + flagSpec "OverloadedRecordUpdate" LangExt.OverloadedRecordUpdate, depFlagSpec' "RecordPuns" LangExt.RecordPuns (deprecatedForExtension "NamedFieldPuns"), flagSpec "RecordWildCards" LangExt.RecordWildCards, diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index ab6ebadd06..42ae115dab 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -287,6 +287,18 @@ type instance XRecordUpd GhcPs = NoExtField type instance XRecordUpd GhcRn = NoExtField type instance XRecordUpd GhcTc = RecordUpdTc +type instance XGetField GhcPs = NoExtField +type instance XGetField GhcRn = NoExtField +type instance XGetField GhcTc = Void +-- HsGetField is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + +type instance XProjection GhcPs = NoExtField +type instance XProjection GhcRn = NoExtField +type instance XProjection GhcTc = Void +-- HsProjection is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + type instance XExprWithTySig (GhcPass _) = NoExtField type instance XArithSeq GhcPs = NoExtField @@ -509,8 +521,15 @@ ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds }) GhcRn -> ppr con GhcTc -> ppr con -ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) - = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) +ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds }) + = case flds of + Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + Right pbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds)))) + +ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field }) + = ppr fexp <> dot <> ppr field + +ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (punctuate dot (map ppr flds))) ppr_expr (ExprWithTySig _ expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) @@ -655,6 +674,8 @@ hsExprNeedsParens p = go go (HsBinTick _ _ _ (L _ e)) = go e go (RecordCon{}) = False go (HsRecFld{}) = False + go (HsProjection{}) = True + go (HsGetField{}) = False go (XExpr x) | GhcTc <- ghcPass @p = case x of @@ -828,7 +849,47 @@ A general recipe to follow this approach for new constructs could go as follows: - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we typecheck the desugared expression while reporting the original one in errors +-} +{- Note [Overview of record dot syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the note that explains all the moving parts for record dot +syntax. + +The language extensions @OverloadedRecordDot@ and +@OverloadedRecordUpdate@ (providing "record dot syntax") are +implemented using the techniques of Note [Rebindable syntax and +HsExpansion]. + +When OverloadedRecordDot is enabled: +- Field selection expressions + - e.g. foo.bar.baz + - Have abstract syntax HsGetField + - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions +- Field selector expressions e.g. (.x.y) + - Have abstract syntax HsProjection + - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions + +When OverloadedRecordUpdate is enabled: +- Record update expressions + - e.g. a{foo.bar=1, quux="corge", baz} + - Have abstract syntax RecordUpd + - With rupd_flds containting a Right + - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr) + - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions + - Note that this is true for all record updates even for those that do not involve '.' + +When OverloadedRecordDot is enabled and RebindableSyntax is not +enabled the name 'getField' is resolved to GHC.Records.getField. When +OverloadedRecordDot is enabled and RebindableSyntax is enabled the +name 'getField' is whatever in-scope name that is. + +When OverloadedRecordUpd is enabled and RebindableSyntax is not +enabled it is an error for now (temporary while we wait on native +setField support; see +https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When +OverloadedRecordUpd is enabled and RebindableSyntax is enabled the +names 'getField' and 'setField' are whatever in-scope names they are. -} -- See Note [Rebindable syntax and HsExpansion] just above. diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 9aadaff9fd..3a8c106b90 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -595,10 +595,14 @@ addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) = do { rec_binds' <- addTickHsRecordBinds rec_binds ; return (expr { rcon_flds = rec_binds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) +addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = flds' }) } + ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) } +addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds }) + = do { e' <- addTickLHsExpr e + ; flds' <- mapM addTickHsRecField flds + ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) } addTickHsExpr (ExprWithTySig x e ty) = liftM3 ExprWithTySig @@ -627,6 +631,8 @@ addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e addTickHsExpr e@(HsSpliceE {}) = return e +addTickHsExpr e@(HsGetField {}) = return e +addTickHsExpr e@(HsProjection {}) = return e addTickHsExpr (HsProc x pat cmdtop) = liftM2 (HsProc x) (addTickLPat pat) @@ -987,7 +993,6 @@ addTickHsRecField (L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr ; return (L l (HsRecField id expr' pun)) } - addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) = liftM From diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 50d9594e3c..387963827e 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -276,6 +276,9 @@ dsExpr (ExprWithTySig _ e _) = dsLExpr e dsExpr (HsConLikeOut _ con) = dsConLike con dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" +dsExpr (HsGetField x _ _) = absurd x +dsExpr (HsProjection x _) = absurd x + dsExpr (HsLit _ lit) = do { warnAboutOverflowedLit lit ; dsLit (convertLit lit) } @@ -603,7 +606,11 @@ we want, namely -} -dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields +dsExpr RecordUpd { rupd_flds = Right _} = + -- Not possible due to elimination in the renamer. See Note + -- [Handling overloaded and rebindable constructs] + panic "The impossible happened" +dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields , rupd_ext = RecordUpdTc { rupd_cons = cons_to_upd , rupd_in_tys = in_inst_tys diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index d3453fcd56..149c683d83 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1581,10 +1581,15 @@ repE (RecordCon { rcon_con = c, rcon_flds = flds }) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) +repE (RecordUpd { rupd_expr = e, rupd_flds = Left flds }) = do { x <- repLE e; fs <- repUpdFields flds; repRecUpd x fs } +repE (RecordUpd { rupd_flds = Right _ }) + = do + -- Not possible due to elimination in the renamer. See Note + -- [Handling overloaded and rebindable constructs] + panic "The impossible has happened!" repE (ExprWithTySig _ e wc_ty) = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $ diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 3fe14085a9..4c75399ee0 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1118,10 +1118,13 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where con_name = case hiePass @p of -- Like ConPat HieRn -> con HieTc -> fmap conLikeName con - RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + RecordUpd {rupd_expr = expr, rupd_flds = Left upds}-> [ toHie expr , toHie $ map (RC RecFieldAssign) upds ] + RecordUpd {rupd_expr = expr, rupd_flds = Right _}-> + [ toHie expr + ] ExprWithTySig _ expr sig -> [ toHie expr , toHie $ TS (ResolvedScopes [mkLScope expr]) sig @@ -1159,6 +1162,8 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where HsSpliceE _ x -> [ toHie $ L mspan x ] + HsGetField {} -> [] + HsProjection {} -> [] XExpr x | GhcTc <- ghcPass @p , WrapExpr (HsWrap w a) <- x diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index ff380f8c75..df581b1898 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -64,7 +64,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS ) +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Fixity @@ -658,6 +658,8 @@ are the most common patterns, rewritten as regular expressions for clarity: '-<<' { L _ (ITLarrowtail _) } -- for arrow notation '>>-' { L _ (ITRarrowtail _) } -- for arrow notation '.' { L _ ITdot } + PREFIX_PROJ { L _ (ITproj True) } -- RecordDotSyntax + TIGHT_INFIX_PROJ { L _ (ITproj False) } -- RecordDotSyntax PREFIX_AT { L _ ITtypeApp } PREFIX_PERCENT { L _ ITpercent } -- for linear types @@ -2737,6 +2739,22 @@ fexp :: { ECP } fmap ecpFromExp $ ams (sLL $1 $> $ HsStatic noExtField $2) [mj AnnStatic $1] } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | fexp TIGHT_INFIX_PROJ field + {% runPV (unECP $1) >>= \ $1 -> + -- Suppose lhs is an application term e.g. 'f a' + -- and rhs is '.b'. Usually we want the parse 'f + -- (a.b)' rather than '(f a).b.'. However, if lhs + -- is a projection 'r.a' (say) then we want the + -- parse '(r.a).b'. + fmap ecpFromExp $ ams (case $1 of + L _ (HsApp _ f arg) | not $ isGetField f -> + let l = comb2 arg $3 in + L (getLoc f `combineSrcSpans` l) + (HsApp noExtField f (mkRdrGetField l arg $3)) + _ -> mkRdrGetField (comb2 $1 $>) $1 $3) [mj AnnDot $2] } + | aexp { $1 } aexp :: { ECP } @@ -2826,10 +2844,12 @@ aexp :: { ECP } aexp1 :: { ECP } : aexp1 '{' fbinds '}' { ECP $ - unECP $1 >>= \ $1 -> - $3 >>= \ $3 -> - amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) - (moc $2:mcc $4:(fst $3)) } + getBit OverloadedRecordUpdateBit >>= \ overloaded -> + unECP $1 >>= \ $1 -> + $3 >>= \ $3 -> + amms (mkHsRecordPV overloaded (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) + (moc $2:mcc $4:(fst $3)) + } | aexp2 { $1 } aexp2 :: { ECP } @@ -2858,6 +2878,14 @@ aexp2 :: { ECP } amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2)) ((mop $1:fst $2) ++ [mcp $3]) } + -- This case is only possible when 'OverloadedRecordDotBit' is enabled. + | '(' projection ')' { ECP $ + let (loc, (anns, fIELDS)) = $2 + span = combineSrcSpans (combineSrcSpans (getLoc $1) loc) (getLoc $3) + expr = mkRdrProjection span (reverse fIELDS) + in amms (ecpFromExp' expr) ([mop $1] ++ reverse anns ++ [mcp $3]) + } + | '(#' texp '#)' { ECP $ unECP $2 >>= \ $2 -> amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)])) @@ -2907,6 +2935,14 @@ aexp2 :: { ECP } Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } +projection :: { (SrcSpan, ([AddAnn], [Located FastString])) } +projection + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer + : projection TIGHT_INFIX_PROJ field + { let (loc, (anns, fs)) = $1 in + (combineSrcSpans (combineSrcSpans loc (gl $2)) (gl $3), (mj AnnDot $2 : anns, $3 : fs)) } + | PREFIX_PROJ field { (comb2 $1 $2, ([mj AnnDot $1], [$2])) } + splice_exp :: { LHsExpr GhcPs } : splice_untyped { mapLoc (HsSpliceE noExtField) $1 } | splice_typed { mapLoc (HsSpliceE noExtField) $1 } @@ -3323,33 +3359,65 @@ qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } +fbinds :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) } : fbinds1 { $1 } | {- empty -} { return ([],([], Nothing)) } -fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } +fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) } : fbind ',' fbinds1 { $1 >>= \ $1 -> $3 >>= \ $3 -> - addAnnotation (gl $1) AnnComma (gl $2) >> + let gl' = \case { Left (L l _) -> l; Right (L l _) -> l } in + addAnnotation (gl' $1) AnnComma (gl $2) >> return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } | fbind { $1 >>= \ $1 -> return ([],([$1], Nothing)) } | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) } -fbind :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) } +fbind :: { forall b. DisambECP b => PV (Fbind b) } : qvar '=' texp { unECP $3 >>= \ $3 -> - ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) - [mj AnnEqual $2] } + fmap Left $ ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2] + } -- RHS is a 'texp', allowing view patterns (#6038) -- and, incidentally, sections. Eg -- f (R { x = show -> s }) = ... | qvar { placeHolderPunRhs >>= \rhs -> - return $ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True } + fmap Left $ return (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True) + } -- In the punning case, use a place-holder -- The renamer fills in the final value + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp + { do + let top = $1 + fields = top : reverse $3 + final = last fields + l = comb2 top final + isPun = False + $5 <- unECP $5 + fmap Right $ mkHsProjUpdatePV (comb2 $1 $5) (L l fields) $5 isPun + } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | field TIGHT_INFIX_PROJ fieldToUpdate + { do + let top = $1 + fields = top : reverse $3 + final = last fields + l = comb2 top final + isPun = True + var <- mkHsVarPV (noLoc (mkRdrUnqual . mkVarOcc . unpackFS . unLoc $ final)) + fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun + } + +fieldToUpdate :: { [Located FastString] } +fieldToUpdate + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + : fieldToUpdate TIGHT_INFIX_PROJ field { $3 : $1 } + | field { [$1] } + ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -3649,6 +3717,9 @@ qvar :: { Located RdrName } -- whether it's a qvar or a var can be postponed until -- *after* we see the close paren. +field :: { Located FastString } + : VARID { sL1 $1 $! getVARID $1 } + qvarid :: { Located RdrName } : varid { $1 } | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index f0f4372c8a..83812f7673 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -153,6 +153,15 @@ data PsErrorDesc | PsErrPrecedenceOutOfRange !Int -- ^ Precedence out of range + | PsErrOverloadedRecordDotInvalid + -- ^ Invalid use of record dot syntax `.' + + | PsErrOverloadedRecordUpdateNotEnabled + -- ^ `OverloadedRecordUpdate` is not enabled. + + | PsErrOverloadedRecordUpdateNoQualifiedFields + -- ^ Can't use qualified fields when OverloadedRecordUpdate is enabled. + | PsErrInvalidDataCon !(HsType GhcPs) -- ^ Cannot parse data constructor in a data/newtype declaration diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 8e083b0141..47c8104fd1 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -234,6 +234,15 @@ pp_err = \case PsErrPrecedenceOutOfRange i -> text "Precedence out of range: " <> int i + PsErrOverloadedRecordDotInvalid + -> text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)" + + PsErrOverloadedRecordUpdateNoQualifiedFields + -> text "Fields cannot be qualified when OverloadedRecordUpdate is enabled" + + PsErrOverloadedRecordUpdateNotEnabled + -> text "OverloadedRecordUpdate needs to be enabled" + PsErrInvalidDataCon t -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2 (ppr t) @@ -607,4 +616,3 @@ pp_hint = \case perhaps_as_pat :: SDoc perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" - diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index b7a3daced5..71fccbe7c5 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -616,6 +616,19 @@ $tab { warnTab } -- | | ordinary operator or type operator, -- | | e.g. xs ~ 3, (~ x), Int ~ Bool -- ----------+---------------+------------------------------------------ +-- . | prefix | ITproj True +-- | | field projection, +-- | | e.g. .x +-- | tight infix | ITproj False +-- | | field projection, +-- | | e.g. r.x +-- | suffix | ITdot +-- | | function composition, +-- | | e.g. f. g +-- | loose infix | ITdot +-- | | function composition, +-- | | e.g. f . g +-- ----------+---------------+------------------------------------------ -- $ $$ | prefix | ITdollar, ITdollardollar -- | | untyped or typed Template Haskell splice, -- | | e.g. $(f x), $$(f x), $$"str" @@ -777,6 +790,7 @@ data Token | ITpercent -- Prefix (%) only, e.g. a %1 -> b | ITstar IsUnicodeSyntax | ITdot + | ITproj Bool -- Extension: OverloadedRecordDotBit | ITbiglam -- GHC-extension symbols @@ -1594,6 +1608,9 @@ varsym_prefix = sym $ \span exts s -> | s == fsLit "-" -> return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus -- and don't hit this code path. See Note [Minus tokens] + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> + return (ITproj True) -- e.g. '(.x)' + | s == fsLit "." -> return ITdot | s == fsLit "!" -> return ITbang | s == fsLit "~" -> return ITtilde | otherwise -> @@ -1614,8 +1631,10 @@ varsym_suffix = sym $ \span _ s -> -- See Note [Whitespace-sensitive operator parsing] varsym_tight_infix :: Action -varsym_tight_infix = sym $ \span _ s -> +varsym_tight_infix = sym $ \span exts s -> if | s == fsLit "@" -> return ITat + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) + | s == fsLit "." -> return ITdot | otherwise -> do { addWarning Opt_WarnOperatorWhitespace $ PsWarnOperatorWhitespace (mkSrcSpanPs span) s @@ -1624,7 +1643,11 @@ varsym_tight_infix = sym $ \span _ s -> -- See Note [Whitespace-sensitive operator parsing] varsym_loose_infix :: Action -varsym_loose_infix = sym (\_ _ s -> return $ ITvarsym s) +varsym_loose_infix = sym $ \_ _ s -> + if | s == fsLit "." + -> return ITdot + | otherwise + -> return $ ITvarsym s consym :: Action consym = sym (\_span _exts s -> return $ ITconsym s) @@ -1632,8 +1655,13 @@ consym = sym (\_span _exts s -> return $ ITconsym s) sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword, NormalSyntax, 0) -> - return $ L span keyword + Just (keyword, NormalSyntax, 0) -> do + exts <- getExts + if fs == fsLit "." && + exts .&. (xbit OverloadedRecordDotBit) /= 0 && + xtest OverloadedRecordDotBit exts + then L span <$!> con span exts fs -- Process by varsym_*. + else return $ L span keyword Just (keyword, NormalSyntax, i) -> do exts <- getExts if exts .&. i /= 0 @@ -2641,6 +2669,8 @@ data ExtBits | ImportQualifiedPostBit | LinearTypesBit | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit] + | OverloadedRecordDotBit + | OverloadedRecordUpdateBit -- Flags that are updated once parsing starts | InRulePragBit @@ -2716,7 +2746,9 @@ mkParserOpts warningFlags extensionFlags .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost .|. LinearTypesBit `xoptBit` LangExt.LinearTypes - .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] + .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] + .|. OverloadedRecordDotBit `xoptBit` LangExt.OverloadedRecordDot + .|. OverloadedRecordUpdateBit `xoptBit` LangExt.OverloadedRecordUpdate -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information). optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 3159902647..234df36be9 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -15,6 +16,7 @@ -- Functions over HsSyn specialised to RdrName. module GHC.Parser.PostProcess ( + mkRdrGetField, mkRdrProjection, isGetField, Fbind, -- RecordDot mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkSpliceDecl, @@ -27,7 +29,7 @@ module GHC.Parser.PostProcess ( mkFamDecl, mkInlinePragma, mkPatSynMatchGroup, - mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkRecConstrOrUpdate, mkTyClD, mkInstD, mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace, @@ -107,7 +109,7 @@ module GHC.Parser.PostProcess ( import GHC.Prelude import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import GHC.Core.DataCon ( DataCon, dataConTyCon ) +import GHC.Core.DataCon ( DataCon, dataConTyCon, FieldLabelString ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader @@ -135,7 +137,8 @@ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc import GHC.Parser.Annotation -import Data.List (findIndex) +import Data.Either +import Data.List import Data.Foldable import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic @@ -148,7 +151,6 @@ import Data.Kind ( Type ) #include "HsVersions.h" - {- ********************************************************************** Construction functions for Rdr stuff @@ -1243,6 +1245,10 @@ ecpFromExp a = ECP (ecpFromExp' a) ecpFromCmd :: LHsCmd GhcPs -> ECP ecpFromCmd a = ECP (ecpFromCmd' a) +-- The 'fbinds' parser rule produces values of this type. See Note +-- [RecordDotSyntax field updates]. +type Fbind b = Either (LHsRecField GhcPs (Located b)) (LHsRecProj GhcPs (Located b)) + -- | Disambiguate infix operators. -- See Note [Ambiguous syntactic categories] class DisambInfixOp b where @@ -1270,6 +1276,8 @@ class b ~ (Body b) GhcPs => DisambECP b where ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) -- | Return an expression without ambiguity, or fail in a non-expression context. ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) + -- | This can only be satified by expressions. + mkHsProjUpdatePV :: SrcSpan -> Located [Located FieldLabelString] -> Located b -> Bool -> PV (LHsRecProj GhcPs (Located b)) -- | Disambiguate "\... -> ..." (lambda) mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) -- | Disambiguate "let ... in ..." @@ -1326,10 +1334,11 @@ class b ~ (Body b) GhcPs => DisambECP b where mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) mkHsRecordPV :: + Bool -> -- Is OverloadedRecordUpdate in effect? SrcSpan -> SrcSpan -> Located b -> - ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> + ([Fbind b], Maybe SrcSpan) -> PV (Located b) -- | Disambiguate "-a" (negation) mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) @@ -1348,7 +1357,6 @@ class b ~ (Body b) GhcPs => DisambECP b where -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas rejectPragmaPV :: Located b -> PV () - {- Note [UndecidableSuperClasses for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (This Note is about the code in GHC, not about the user code that we are parsing) @@ -1397,6 +1405,7 @@ instance DisambECP (HsCmd GhcPs) where type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return ecpFromExp' (L l e) = cmdFail l (ppr e) + mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg) mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e) type InfixOp (HsCmd GhcPs) = HsExpr GhcPs @@ -1427,8 +1436,11 @@ instance DisambECP (HsCmd GhcPs) where mkHsExplicitListPV l xs = cmdFail l $ brackets (fsep (punctuate comma (map ppr xs))) mkHsSplicePV (L l sp) = cmdFail l (ppr sp) - mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ - ppr a <+> ppr (mk_rec_fields fbinds ddLoc) + mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $ let pp_op = fromMaybe (panic "cannot print infix operator") @@ -1454,6 +1466,7 @@ instance DisambECP (HsExpr GhcPs) where addError $ PsError (PsErrArrowCmdInExpr c) [] l return (L l hsHoleExpr) ecpFromExp' = return + mkHsProjUpdatePV l fields arg isPun = return $ mkRdrProjUpdate l fields arg isPun mkHsLamPV l mg = return $ L l (HsLam noExtField mg) mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs @@ -1483,8 +1496,8 @@ instance DisambECP (HsExpr GhcPs) where mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig)) mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField xs) mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp - mkHsRecordPV l lrec a (fbinds, ddLoc) = do - r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) + mkHsRecordPV opts l lrec a (fbinds, ddLoc) = do + r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) checkRecordSyntax (L l r) mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e) @@ -1512,6 +1525,7 @@ instance DisambECP (PatBuilder GhcPs) where ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] l mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l mkHsLetPV l _ _ = addFatalError $ PsError PsErrLetInPat [] l + mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 @@ -1537,9 +1551,13 @@ instance DisambECP (PatBuilder GhcPs) where ps <- traverse checkLPat xs return (L l (PatBuilderPat (ListPat noExtField ps))) mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) - mkHsRecordPV l _ a (fbinds, ddLoc) = do - r <- mkPatRec a (mk_rec_fields fbinds ddLoc) - checkRecordSyntax (L l r) + mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + else do + r <- mkPatRec a (mk_rec_fields fs ddLoc) + checkRecordSyntax (L l r) mkHsNegAppPV l (L lp p) = do lit <- case p of PatBuilderOverLit pos_lit -> return (L lp pos_lit) @@ -2135,23 +2153,71 @@ checkPrecP (L l (_,i)) (L _ ol) , getRdrName unrestrictedFunTyCon ] mkRecConstrOrUpdate - :: LHsExpr GhcPs + :: Bool + -> LHsExpr GhcPs -> SrcSpan - -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) + -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) -> PV (HsExpr GhcPs) - -mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) +mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _lrec (fbinds,dd) | isRdrDataCon c - = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp _ (fs,dd) + = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLoc (head ps)) + else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) +mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc - | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) - -mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs -mkRdrRecordUpd exp flds - = RecordUpd { rupd_ext = noExtField - , rupd_expr = exp - , rupd_flds = flds } + | otherwise = mkRdrRecordUpd overloaded_update exp fs + +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs) +mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do + -- We do not need to know if OverloadedRecordDot is in effect. We do + -- however need to know if OverloadedRecordUpdate (passed in + -- overloaded_on) is in effect because it affects the Left/Right nature + -- of the RecordUpd value we calculate. + let (fs, ps) = partitionEithers fbinds + fs' = map (fmap mk_rec_upd_field) fs + case overloaded_on of + False | not $ null ps -> + -- A '.' was found in an update and OverloadedRecordUpdate isn't on. + addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] loc + False -> + -- This is just a regular record update. + return RecordUpd { + rupd_ext = noExtField + , rupd_expr = exp + , rupd_flds = Left fs' } + True -> do + let qualifiedFields = + [ L l lbl | L _ (HsRecField (L l lbl) _ _) <- fs' + , isQual . rdrNameAmbiguousFieldOcc $ lbl + ] + if not $ null qualifiedFields + then + addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields)) + else -- This is a RecordDotSyntax update. + return RecordUpd { + rupd_ext = noExtField + , rupd_expr = exp + , rupd_flds = Right (toProjUpdates fbinds) } + where + toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs] + toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f }) + + -- Convert a top-level field update like {foo=2} or {bar} (punned) + -- to a projection update. + recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs + recFieldToProjUpdate (L l (HsRecField (L _ (FieldOcc _ (L loc rdr))) arg pun)) = + -- The idea here is to convert the label to a singleton [FastString]. + let f = occNameFS . rdrNameOcc $ rdr + in mkRdrProjUpdate l (L loc [L loc f]) (punnedVar f) pun + where + -- If punning, compute HsVar "f" otherwise just arg. This + -- has the effect that sentinel HsVar "pun-rhs" is replaced + -- by HsVar "f" here, before the update is written to a + -- setField expressions. + punnedVar :: FastString -> LHsExpr GhcPs + punnedVar f = if not pun then arg else noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOccFS $ f mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds @@ -2632,3 +2698,36 @@ mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok)) starSym :: Bool -> String starSym True = "★" starSym False = "*" + +----------------------------------------- +-- Bits and pieces for RecordDotSyntax. + +-- Test if the expression is a 'getField @"..."' expression. +isGetField :: LHsExpr GhcPs -> Bool +isGetField (L _ HsGetField{}) = True +isGetField _ = False + +mkRdrGetField :: SrcSpan -> LHsExpr GhcPs -> Located FieldLabelString -> LHsExpr GhcPs +mkRdrGetField loc arg field = + L loc HsGetField { + gf_ext = noExtField + , gf_expr = arg + , gf_field = field + } + +mkRdrProjection :: SrcSpan -> [Located FieldLabelString] -> LHsExpr GhcPs +mkRdrProjection _ [] = panic "mkRdrProjection: The impossible has happened!" +mkRdrProjection loc flds = + L loc HsProjection { + proj_ext = noExtField + , proj_flds = flds + } + +mkRdrProjUpdate :: SrcSpan -> Located [Located FieldLabelString] -> LHsExpr GhcPs -> Bool -> LHsRecProj GhcPs (LHsExpr GhcPs) +mkRdrProjUpdate _ (L _ []) _ _ = panic "mkRdrProjUpdate: The impossible has happened!" +mkRdrProjUpdate loc (L l flds) arg isPun = + L loc HsRecField { + hsRecFieldLbl = L l (FieldLabelStrings flds) + , hsRecFieldArg = arg + , hsRecPun = isPun + } diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index fad921265a..1ffbc4371a 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -304,6 +304,25 @@ rnExpr (NegApp _ e _) ; return (final_e, fv_e `plusFV` fv_neg) } ------------------------------------------ +-- Record dot syntax + +rnExpr (HsGetField _ e f) + = do { (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (e, fv_e) <- rnLExpr e + ; return ( mkExpandedExpr + (HsGetField noExtField e f) + (mkGetField getField e f) + , fv_e `plusFV` fv_getField ) } + +rnExpr (HsProjection _ fs) + = do { (getField, fv_getField) <- lookupSyntaxName getFieldName + ; circ <- lookupOccRn compose_RDR + ; return ( mkExpandedExpr + (HsProjection noExtField fs) + (mkProjection getField circ fs) + , unitFV circ `plusFV` fv_getField) } + +------------------------------------------ -- Template Haskell extensions rnExpr e@(HsBracket _ br_body) = rnBracket e br_body @@ -406,11 +425,28 @@ rnExpr (RecordCon { rcon_con = con_id ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) - = do { (expr', fvExpr) <- rnLExpr expr - ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr' - , rupd_flds = rbinds' } - , fvExpr `plusFV` fvRbinds) } + = case rbinds of + Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update. + do { ; (e, fv_e) <- rnLExpr expr + ; (rs, fv_rs) <- rnHsRecUpdFields flds + ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs ) + } + Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. + do { ; unlessXOptM LangExt.RebindableSyntax $ + addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." + ; let punnedFields = [fld | (L _ fld) <- flds, hsRecPun fld] + ; punsEnabled <-xoptM LangExt.RecordPuns + ; unless (null punnedFields || punsEnabled) $ + addErr $ text "For this to work enable NamedFieldPuns." + ; (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (setField, fv_setField) <- lookupSyntaxName setFieldName + ; (e, fv_e) <- rnLExpr expr + ; (us, fv_us) <- rnHsUpdProjs flds + ; return ( mkExpandedExpr + (RecordUpd noExtField e (Right us)) + (mkRecordDotUpd getField setField e us) + , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) + } rnExpr (ExprWithTySig _ expr pty) = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty @@ -2497,6 +2533,12 @@ genLHsVar nm = wrapGenSpan $ genHsVar nm genHsVar :: Name -> HsExpr GhcRn genHsVar nm = HsVar noExtField $ wrapGenSpan nm +genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn +genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan + +genHsTyLit :: FastString -> HsType GhcRn +genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText + wrapGenSpan :: a -> Located a -- Wrap something in a "generatedSrcSpan" -- See Note [Rebindable syntax and HsExpansion] @@ -2510,3 +2552,72 @@ mkExpandedExpr -> HsExpr GhcRn -- ^ expanded expression -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion' mkExpandedExpr a b = XExpr (HsExpanded a b) + +----------------------------------------- +-- Bits and pieces for RecordDotSyntax. +-- +-- See Note [Overview of record dot syntax] in GHC.Hs.Expr. + +-- mkGetField arg field calcuates a get_field @field arg expression. +-- e.g. z.x = mkGetField z x = get_field @x z +mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn +mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field) + +-- mkSetField a field b calculates a set_field @field expression. +-- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b"). +mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn +mkSetField set_field a (L _ field) b = + genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b + +mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn] +mkGet get_field l@(r : _) (L _ field) = + wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l +mkGet _ [] _ = panic "mkGet : The impossible has happened!" + +mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn +mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc) + +-- mkProjection fields calculates a projection. +-- e.g. .x = mkProjection [x] = getField @"x" +-- .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x" +mkProjection :: Name -> Name -> [Located FieldLabelString] -> HsExpr GhcRn +mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields + where + f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn + f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] + + proj :: Located FieldLabelString -> HsExpr GhcRn + proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f +mkProjection _ _ [] = panic "mkProjection: The impossible happened" + +-- mkProjUpdateSetField calculates functions representing dot notation record updates. +-- e.g. Suppose an update like foo.bar = 1. +-- We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). +mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn) +mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds)), hsRecFieldArg = arg } )) + = let { + ; final = last flds -- quux + ; fields = init flds -- [foo, bar, baz] + ; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow. + -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a] + ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow. + -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)] + } + in (\a -> foldl' (mkSet set_field) arg (zips a)) + -- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux)))) + +mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn +mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates + where + fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn + fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc) + +rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars) +rnHsUpdProjs us = do + (u, fvs) <- unzip <$> mapM rnRecUpdProj us + pure (u, plusFVs fvs) + where + rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars) + rnRecUpdProj (L l (HsRecField fs arg pun)) + = do { (arg, fv) <- rnLExpr arg + ; return $ (L l (HsRecField { hsRecFieldLbl = fs, hsRecFieldArg = arg, hsRecPun = pun}), fv) } diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index dc0d244fc1..a74af6e564 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -639,7 +639,11 @@ following. -} -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty +-- Record updates via dot syntax are replaced by desugared expressions +-- in the renamer. See Note [Overview of record dot syntax] in +-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here +-- and panic otherwise. +tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty = ASSERT( notNull rbnds ) do { -- STEP -2: typecheck the record_expr, the record to be updated (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr @@ -805,11 +809,12 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty , rupd_out_tys = result_inst_tys , rupd_wrap = req_wrap } expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $ - mkLHsWrapCo co_scrut record_expr' - , rupd_flds = rbinds' + mkLHsWrapCo co_scrut record_expr' + , rupd_flds = Left rbinds' , rupd_ext = upd_tc } ; tcWrapResult expr expr' rec_res_ty res_ty } +tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!" {- @@ -828,6 +833,19 @@ tcExpr (ArithSeq _ witness seq) res_ty {- ************************************************************************ * * + Record dot syntax +* * +************************************************************************ +-} + +-- These terms have been replaced by desugaring in the renamer. See +-- Note [Overview of record dot syntax]. +tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented" +tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented" + +{- +************************************************************************ +* * Template Haskell * * ************************************************************************ @@ -1274,7 +1292,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." ] where - rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds, rupd_ext = noExtField } + rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } loc = getLoc (head rbnds) {- diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 648bf5ce12..b1dd472d75 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -375,6 +375,7 @@ data CtOrigin | AssocFamPatOrigin -- When matching the patterns of an associated -- family instance with that of its parent class | SectionOrigin + | HasFieldOrigin FastString | TupleOrigin -- (..,..) | ExprSigOrigin -- e :: ty | PatSigOrigin -- p :: ty @@ -478,6 +479,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name +exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin f exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) @@ -493,6 +495,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e +exprCtOrigin (HsProjection _ _) = SectionOrigin exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" @@ -629,6 +632,7 @@ pprCtO IfOrigin = text "an if expression" pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] pprCtO SectionOrigin = text "an operator section" +pprCtO (HasFieldOrigin f) = hsep [text "selecting the field", quotes (ppr f)] pprCtO AssocFamPatOrigin = text "the LHS of a family instance" pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 4d4860c7e1..90717063f7 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -946,21 +946,31 @@ zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) ; return (expr { rcon_ext = new_con_expr , rcon_flds = new_rbinds }) } -zonkExpr env (RecordUpd { rupd_flds = rbinds +-- Record updates via dot syntax are replaced by desugared expressions +-- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This +-- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise. +zonkExpr env (RecordUpd { rupd_flds = Left rbinds , rupd_expr = expr - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) + , rupd_ext = RecordUpdTc { + rupd_cons = cons + , rupd_in_tys = in_tys + , rupd_out_tys = out_tys + , rupd_wrap = req_wrap }}) = do { new_expr <- zonkLExpr env expr ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys ; new_rbinds <- zonkRecUpdFields env rbinds ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } + ; return ( + RecordUpd { + rupd_expr = new_expr + , rupd_flds = Left new_rbinds + , rupd_ext = RecordUpdTc { + rupd_cons = cons + , rupd_in_tys = new_in_tys + , rupd_out_tys = new_out_tys + , rupd_wrap = new_recwrap }}) } +zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!" zonkExpr env (ExprWithTySig _ e ty) = do { e' <- zonkLExpr env e diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 12f65d36ca..29976e4b89 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1020,7 +1020,7 @@ cvtl e = wrapL (cvt e) ; flds' <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) flds - ; return $ mkRdrRecordUpd e' flds' } + ; return $ RecordUpd noExtField e' (Left flds') } cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is -- important, because UnboundVarE may contain diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 3d6500d342..9967a78314 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -40,6 +40,7 @@ import Language.Haskell.Syntax.Binds -- others: import GHC.Tc.Types.Evidence import GHC.Core +import GHC.Core.DataCon (FieldLabelString) import GHC.Types.Name import GHC.Types.Basic import GHC.Types.Fixity @@ -59,6 +60,110 @@ import qualified Data.Data as Data (Fixity(..)) import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) +{- Note [RecordDotSyntax field updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The extensions @OverloadedRecordDot@ @OverloadedRecordUpdate@ together +enable record updates like @a{foo.bar.baz = 1}@. Introducing this +syntax slightly complicates parsing. This note explains how it's done. + +In the event a record is being constructed or updated, it's this +production that's in play: +@ +aexp1 -> aexp1 '{' fbinds '}' { + ... + mkHsRecordPV ... $1 (snd $3) +} +@ +@fbinds@ is a list of field bindings. @mkHsRecordPV@ is a function of +the @DisambECP b@ typeclass, see Note [Ambiguous syntactic +categories]. + +The "normal" rules for an @fbind@ are: +@ +fbind + : qvar '=' texp + | qvar +@ +These rules compute values of @LHsRecField GhcPs (Located b)@. They +apply in the context of record construction, record updates, record +patterns and record expressions. That is, @b@ ranges over @HsExpr +GhcPs@, @HsPat GhcPs@ and @HsCmd GhcPs@. + +When @OverloadedRecordDot@ and @OverloadedRecordUpdate@ are both +enabled, two additional @fbind@ rules are admitted: +@ + | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp + | field TIGHT_INFIX_PROJ fieldToUpdate +@ + +These rules only make sense when parsing record update expressions +(that is, patterns and commands cannot be parsed by these rules and +neither record constructions). + +The results of these new rules cannot be represented by @LHsRecField +GhcPs (LHsExpr GhcPs)@ values as the type is defined today. We +minimize modifying existing code by having these new rules calculate +@LHsRecProj GhcPs (Located b)@ ("record projection") values instead: +@ +newtype FieldLabelStrings = FieldLabelStrings [Located FieldLabelString] +type RecProj arg = HsRecField' FieldLabelStrings arg +type LHsRecProj p arg = Located (RecProj arg) +@ + +The @fbind@ rule is then given the type @fbind :: { forall b. +DisambECP b => PV (Fbind b) }@ accomodating both alternatives: +@ +type Fbind b = Either + (LHsRecField GhcPs (Located b)) + ( LHsRecProj GhcPs (Located b)) +@ + +In @data HsExpr p@, the @RecordUpd@ constuctor indicates regular +updates vs. projection updates by means of the @rupd_flds@ member +type, an @Either@ instance: +@ + | RecordUpd + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p + , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p] + } +@ +Here, +@ +type RecUpdProj p = RecProj (LHsExpr p) +type LHsRecUpdProj p = Located (RecUpdProj p) +@ +and @Left@ values indicating regular record update, @Right@ values +updates desugared to @setField@s. + +If @OverloadedRecordUpdate@ is enabled, any updates parsed as +@LHsRecField GhcPs@ values are converted to @LHsRecUpdProj GhcPs@ +values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess'). +-} + +-- | RecordDotSyntax field updates + +newtype FieldLabelStrings = + FieldLabelStrings [Located FieldLabelString] + deriving (Data) + +instance Outputable FieldLabelStrings where + ppr (FieldLabelStrings flds) = + hcat (punctuate dot (map (ppr . unLoc) flds)) + +-- Field projection updates (e.g. @foo.bar.baz = 1@). See Note +-- [RecordDotSyntax field updates]. +type RecProj arg = HsRecField' FieldLabelStrings arg + +-- The phantom type parameter @p@ is for symmetry with @LHsRecField p +-- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process). +type LHsRecProj p arg = Located (RecProj arg) + +-- These two synonyms are used in the definition of syntax @RecordUpd@ +-- below. +type RecUpdProj p = RecProj (LHsExpr p) +type LHsRecUpdProj p = Located (RecUpdProj p) + {- ************************************************************************ * * @@ -356,16 +461,44 @@ data HsExpr p -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ + -- 'GHC.Parser.Annotation.AnnComma, 'GHC.Parser.Annotation.AnnDot', + -- 'GHC.Parser.Annotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in GHC.Parser.Annotation | RecordUpd { rupd_ext :: XRecordUpd p , rupd_expr :: LHsExpr p - , rupd_flds :: [LHsRecUpdField p] + , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p] } -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon + -- | Record field selection e.g @z.x@. + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot' + -- + -- This case only arises when the OverloadedRecordDot langauge + -- extension is enabled. + + | HsGetField { + gf_ext :: XGetField p + , gf_expr :: LHsExpr p + , gf_field :: Located FieldLabelString + } + + -- | Record field selector. e.g. @(.x)@ or @(.x.y)@ + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP' + -- 'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP' + -- + -- This case only arises when the OverloadedRecordDot langauge + -- extensions is enabled. + + | HsProjection { + proj_ext :: XProjection p + , proj_flds :: [Located FieldLabelString] + } + -- | Expression with an explicit type signature. @e :: type@ -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 16b11b3e30..f843bee1a2 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -387,6 +387,8 @@ type family XDo x type family XExplicitList x type family XRecordCon x type family XRecordUpd x +type family XGetField x +type family XProjection x type family XExprWithTySig x type family XArithSeq x type family XBracket x diff --git a/docs/users_guide/exts/hasfield.rst b/docs/users_guide/exts/hasfield.rst index d83d3f15bd..5682c9f901 100644 --- a/docs/users_guide/exts/hasfield.rst +++ b/docs/users_guide/exts/hasfield.rst @@ -102,6 +102,8 @@ are generated for each datatype definition: instance (Eq a, a ~ b) => HasField "unSilly" (Silly a) b +See :ref:`overloaded-record-dot` for an application of solving ``HasField`` constraints to implementing "record dot syntax". + .. _virtual-record-fields: Virtual record fields @@ -172,6 +174,3 @@ constraint will not be solved automatically (as described above), but in the interests of simplicity we do not permit users to define their own instances either. If a field is not in scope, the corresponding instance is still prohibited, to avoid conflicts in downstream modules. - - - diff --git a/docs/users_guide/exts/overloaded_record_dot.rst b/docs/users_guide/exts/overloaded_record_dot.rst new file mode 100644 index 0000000000..26f29b352c --- /dev/null +++ b/docs/users_guide/exts/overloaded_record_dot.rst @@ -0,0 +1,34 @@ +.. _overloaded-record-dot: + +Overloaded record dot +--------------------- + +.. extension:: OverloadedRecordDot + :shortdesc: Record '.' syntax + + :since: 9.2.0 + + Provides record '.' syntax e.g. ``x.foo`` + +When ``OverloadedRecordDot`` is enabled one can write ``a.b`` to mean the ``b`` field of the ``a`` record expression. + +Example: + +.. code-block:: haskell + + {-# LANGUAGE OverloadedRecordDot #-} + {-# LANGUAGE DuplicateRecordFields #-} + + data Person = Person { name :: String } + data Company = Company { name :: String, owner :: Person } + + main = do + let c = Company { name = "Acme Corp." + , owner = Person { name = "Wile E. Coyote" } } + print $ c.name ++ " is run by " ++ c.owner.name + +You may also write ``(.b)`` to mean a function that "projects the ``b`` field from its argument". For example, ``(.b) a`` means the same thing as ``a.b``). + +``OverloadedRecordDot`` is normally implemented by desugaring record ``.`` expressions to ``GHC.Records.getField`` expressions. By enabling ``OverloadedRecordDot`` and ``RebindableSyntax`` together it is possible to desugar ``.`` expressions into your own ``getField`` implementations. + +When considering ``a.b``, the ``b`` field that is meant is determined by solving ``HasField`` constraints. See :ref:`solving-hasfield-constraints`. diff --git a/docs/users_guide/exts/overloaded_record_update.rst b/docs/users_guide/exts/overloaded_record_update.rst new file mode 100644 index 0000000000..2e9df747dc --- /dev/null +++ b/docs/users_guide/exts/overloaded_record_update.rst @@ -0,0 +1,61 @@ +.. _overloaded-record-update: + +Overloaded record update +------------------------ + +.. extension:: OverloadedRecordUpdate + :shortdesc: Record '.' syntax record updates + + :since: 9.2.0 + + Provides record '.' syntax in record updates e.g. ``x{foo.bar = 1}``. + +**EXPERIMENTAL** +*This design of this extension may well change in the future. It would be inadvisable to start using this extension for long-lived libraries just yet.* + +It's usual (but not required) that this extension be used in conjunction with :ref:`overloaded-record-dot`. + +Example: + +.. code-block:: haskell + + {-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds, FlexibleInstances #-} + {-# LANGUAGE NamedFieldPuns, RecordWildCards #-} + {-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax #-} + + import Prelude + + class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + + getField :: forall x r a . HasField x r a => r -> a + getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + setField :: forall x r a . HasField x r a => r -> a -> r + setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + + data Person = Person { name :: String } deriving Show + instance HasField "name" Person String where + hasField r = (\x -> case r of Person { .. } -> Person { name = x, .. }, name r) + + data Company = Company { company :: String, owner :: Person } deriving Show + instance HasField "company" Company String where + hasField r = (\x -> case r of Company { .. } -> Company { company = x, .. }, company r) + instance HasField "owner" Company Person where + hasField r = (\x -> case r of Company { .. } -> Company { owner = x, .. }, owner r) + + main = do + let c = Company {company = "Acme Corp.", owner = Person { name = "Wile E. Coyote" }} + + -- Top-level update + print $ c{company = "Acme United"} -- Company {company = "Acme United", owner = Person {name = "Wile E. Coyote"}} + + -- Nested update + print $ c{owner.name = "Walter C. Johnsen"} -- Company {company = "Acme Corp.", owner = Person {name = "Walter C. Johnsen"}} + + -- Punned update + let name = "Walter C. Johnsen" + print $ c{owner.name} -- Company {company = "Acme Corp.", owner = Person {name = "Walter C. Johnsen"}} + +``OverloadedRecordUpdate`` works by desugaring record ``.`` update expressions to expressions involving the functions ``setField`` and ``getField``. Note that all record updates will be desugared to ``setField`` expressions whether they use ``.`` notation or not. + +At this time, ``RebindableSyntax`` must be enabled when ``OverloadedRecordUpdate`` is and users are required to provide definitions for ``getField`` and ``setField``. We anticipate this restriction to be lifted in a future release of GHC with builtin support for ``setField``. diff --git a/docs/users_guide/exts/records.rst b/docs/users_guide/exts/records.rst index 9395cf4666..b1e3f84a7c 100644 --- a/docs/users_guide/exts/records.rst +++ b/docs/users_guide/exts/records.rst @@ -14,3 +14,5 @@ Records record_puns record_wildcards hasfield + overloaded_record_dot + overloaded_record_update diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index a3c3e2edfe..b75977c74c 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -146,6 +146,8 @@ data Extension | StandaloneKindSignatures | LexicalNegation | FieldSelectors + | OverloadedRecordDot + | OverloadedRecordUpdate deriving (Eq, Enum, Show, Generic, Bounded) -- 'Ord' and 'Bounded' are provided for GHC API users (see discussions -- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 27be970d22..cbcbefc573 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -41,6 +41,8 @@ expectedGhcOnlyExtensions = , "AlternativeLayoutRule" , "AlternativeLayoutRuleTransitional" , "FieldSelectors" + , "OverloadedRecordDot" + , "OverloadedRecordUpdate" ] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs new file mode 100644 index 0000000000..22b5aed888 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE RecordWildCards, OverloadedRecordDot, OverloadedRecordUpdate #-} + +module RecordDotSyntaxA where + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +data Foo = Foo {foo :: Int} +instance HasField "foo" Foo Int where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs new file mode 100644 index 0000000000..f7692ec778 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +no = Foo { bar.baz = 1 } + -- Syntax error: Can't use '.' in construction. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr new file mode 100644 index 0000000000..6e4a3fbae6 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr @@ -0,0 +1,2 @@ + RecordDotSyntaxFail0.hs:3:12: + Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns) diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs new file mode 100644 index 0000000000..78b4f1072c --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +no Foo { bar.baz = x } = undefined + -- Syntax error: Field selector syntax doesn't participate + -- in patterns diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr new file mode 100644 index 0000000000..f1ab2b9f95 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail1.hs:3:10: + Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns) diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs new file mode 100644 index 0000000000..cc76b469d5 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +-- 'Foo' has 'foo' field of type 'Bar' +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +instance HasField "foo" Foo Bar where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) + +-- 'Bar' has a 'bar' field of type 'Baz' +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +instance HasField "bar" Bar Baz where + hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r) + +-- 'Baz' has a 'baz' field of type 'Quux' +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +instance HasField "baz" Baz Quux where + hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r) + +-- 'Quux' has a 'quux' field of type 'Int' +data Quux = Quux { quux :: Int } deriving (Show, Eq) +instance HasField "quux" Quux Int where + hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + let quux = "Expecto patronum!" + print $ a{foo.bar.baz.quux} -- Type error. Does a{foo.bar.baz.quux} get underlined? diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr new file mode 100644 index 0000000000..38d9616489 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr @@ -0,0 +1,13 @@ +RecordDotSyntaxFail10.hs:40:11: + Couldn't match type ‘Int’ with ‘[Char]’ + arising from a functional dependency between: + constraint ‘HasField "quux" Quux String’ + arising from a use of ‘setField’ + instance ‘HasField "quux" Quux Int’ + at RecordDotSyntaxFail10.hs:34:10-33 + In the second argument of ‘($)’, namely ‘a {foo.bar.baz.quux}’ + In a stmt of a 'do' block: print $ a {foo.bar.baz.quux} + In the expression: + do let a = ... + let quux = "Expecto patronum!" + print $ a {foo.bar.baz.quux} diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs new file mode 100644 index 0000000000..62f9bd8f23 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Foo = Foo { foo :: Bar } +data Bar = Bar { bar :: Int } + +main = do + let a = Foo { foo = Bar { bar = 1 }} + print $ (.foo.bar.baz) a -- Oops, what is baz? diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr new file mode 100644 index 0000000000..4ca1005185 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr @@ -0,0 +1,25 @@ +RecordDotSyntaxFail11.hs:8:3: + Ambiguous type variable ‘a0’ arising from a use of ‘print’ + prevents the constraint ‘(Show a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. + These potential instances exist: + instance Show Ordering -- Defined in ‘GHC.Show’ + instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ + instance Show Integer -- Defined in ‘GHC.Show’ + ...plus 23 others + ...plus N instances involving out-of-scope types + (use -fprint-potential-instances to see them all) + In the first argument of ‘($)’, namely ‘print’ + In a stmt of a 'do' block: print $ (foo.bar.baz) a + In the expression: + do let a = ... + print $ (foo.bar.baz) a + +RecordDotSyntaxFail11.hs:8:11: + No instance for (GHC.Records.HasField "baz" Int a0) + arising from a use of ‘GHC.Records.getField’ + In the second argument of ‘($)’, namely ‘(foo.bar.baz) a’ + In a stmt of a 'do' block: print $ (foo.bar.baz) a + In the expression: + do let a = ... + print $ (foo.bar.baz) a diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs new file mode 100644 index 0000000000..ba7f7effed --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +-- For "higher kinded data" test. +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +-- Choice (C2a). + +import Data.Function -- for & +import Data.Functor.Identity + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +-- 'Foo' has 'foo' field of type 'Bar' +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +instance HasField "foo" Foo Bar where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) + +-- 'Bar' has a 'bar' field of type 'Baz' +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +instance HasField "bar" Bar Baz where + hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r) + +-- 'Baz' has a 'baz' field of type 'Quux' +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +instance HasField "baz" Baz Quux where + hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r) + +-- 'Quux' has a 'quux' field of type 'Int' +data Quux = Quux { quux :: Int } deriving (Show, Eq) +instance HasField "quux" Quux Int where + hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r) + +-- 'Corge' has a '&&&' field of type 'Int' +data Corge = Corge { (&&&) :: Int } deriving (Show, Eq) +instance HasField "&&&" Corge Int where + hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r) +-- Note : Dot notation is not available for fields with operator +-- names. + +-- 'Grault' has two fields 'f' and 'g' of type 'Foo'. +data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq) +instance HasField "f" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r) +instance HasField "g" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r) + +-- "Higher kinded data" +-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/) +type family H f a where + H Identity a = a + H f a = f a +data P f = P + { n :: H f String + } +-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34. +instance (a ~ H f String) => HasField "n" (P f) a where + hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + let b = Corge{ (&&&) = 12 }; + let c = Grault { + f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } } + , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } } + } + + -- A "selector" is an expression like '(.a)' or '(.a.b)'. + putStrLn "-- selectors:" + print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } } + print $ (.foo.bar.baz) a -- Quux { quux = 42 } + print $ (.foo.bar.baz.quux) a -- 42 + print $ ((&&&) b) -- 12 + -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’ + print $ getField @"&&&" b -- 12 + + -- A "selection" is an expression like 'r.a' or '(f r).a.b'. + putStrLn "-- selections:" + print $ a.foo.bar.baz.quux -- 42 + print $ a.foo.bar.baz -- Quux { quux = 42 } + print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } } + print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (const "hello") a.foo -- f r.x means f (r.x) + -- print $ f a .foo -- f r .x is illegal + print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x) + -- print $ f (g a) .foo -- f (g r) .x is illegal + print $ a.foo + & (.bar.baz.quux) -- 42 + print $ (a.foo + ).bar.baz.quux -- 42 + print $ (+) a.foo.bar.baz.quux 1 -- 43 + print $ (+) (id a).foo.bar.baz.quux 1 -- 43 + print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43 + + -- An "update" is an expression like 'r{ a.b = 12 }'. + putStrLn "-- updates:" + print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 } + print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } } + let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } } + print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } } + print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } } + print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } } + print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } } + + -- A "punned update" is an expression like 'r{ a.b }' (where it is + -- understood that 'b' is a variable binding in the environment of + -- the field update - enabled only when the extension + -- 'NamedFieldPuns' is in effect). + putStrLn "-- punned updates:" + let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } } + print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4 + f <- pure a + g <- pure a + print $ c{ f } -- 42, 1 + print $ c{ f, g } -- 42, 42 + print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4 + + putStrLn "-- misc:" + -- Higher kinded test. + let p = P { n = Just "me" } :: P Maybe + Just me <- pure p.n + putStrLn $ me diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr new file mode 100644 index 0000000000..6ef0a51754 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr @@ -0,0 +1,36 @@ + +RecordDotSyntaxFail12.hs:123:25: + Illegal use of punning for field ‘quux’ + Use NamedFieldPuns to permit this + +RecordDotSyntaxFail12.hs:123:46: + Illegal use of punning for field ‘baz’ + Use NamedFieldPuns to permit this + +RecordDotSyntaxFail12.hs:123:65: + Illegal use of punning for field ‘bar’ + Use NamedFieldPuns to permit this + +RecordDotSyntaxFail12.hs:124:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:125:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:126:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:127:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:129:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:132:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:133:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:134:11: + For this to work enable NamedFieldPuns. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs new file mode 100644 index 0000000000..7050145b9d --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +-- 'Foo' has 'foo' field of type 'Int' +data Foo = Foo { foo :: Int } deriving (Show, Eq) +instance HasField "foo" Foo Int where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) +main = do + let a = Foo {foo = 12}; + -- let foo = 13; + print $ a {foo} diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr new file mode 100644 index 0000000000..8b5369731f --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr @@ -0,0 +1,15 @@ + +RecordDotSyntaxFail13.hs:26:11: + Couldn't match type ‘Int’ with ‘Foo -> Int’ + arising from a functional dependency between: + constraint ‘HasField "foo" Foo (Foo -> Int)’ + << This should not appear in error messages. If you see this + in an error message, please report a bug mentioning ‘record update’ at + https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >> + instance ‘HasField "foo" Foo Int’ + at RecordDotSyntaxFail13.hs:21:10-31 + In the second argument of ‘($)’, namely ‘a {foo}’ + In a stmt of a 'do' block: print $ a {foo} + In the expression: + do let a = ... + print $ a {foo} diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs new file mode 100644 index 0000000000..39a3e0256b --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedRecordDot #-} -- Enable '.' +{-# LANGUAGE NoOverloadedRecordUpdate #-} -- Definitely not enable overloaded updates. + +data Foo = Foo { foo :: Bar } +data Bar = Bar { bar :: Baz } +data Baz = Baz { baz :: Quux } +data Quux = Quux { quux :: Int } + +no :: Foo -> Foo +no foo = foo { bar.baz = Quux { quux = 42 } } } } +-- For this to work, OverloadedRecordUpdate must be enabled diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr new file mode 100644 index 0000000000..5430e37bc9 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail2.hs:10:10: + OverloadedRecordUpdate needs to be enabled diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs new file mode 100644 index 0000000000..ae1a1fa797 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot #-} + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +-- 'Corge' has a '&&&' field of type 'Int' +data Corge = Corge { (&&&) :: Int } deriving (Show, Eq) +instance HasField "&&&" Corge Int where + hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r) + +main = do + let b = Corge { (&&&) = 12 }; + print $ (b.(&&&)) + -- Syntax error: Dot notation is not available for fields with + -- operator names diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr new file mode 100644 index 0000000000..674b0c1e50 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr @@ -0,0 +1 @@ +RecordDotSyntaxFail3.hs:22:14: parse error on input ‘(’ diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs new file mode 100644 index 0000000000..b921cbc4b2 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Foo = Foo { foo :: Int } + +main = do + let a = Foo { foo = 1 } + print $ (const "hello") a .foo + -- Syntax error: f r .x is illegal. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr new file mode 100644 index 0000000000..4ffc9df51e --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail4.hs:7:29: error: + parse error on input ‘.’ diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs new file mode 100644 index 0000000000..c261a571b7 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +{-# LANGUAGE NoRebindableSyntax #-} + +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +data Quux = Quux { quux :: Int } deriving (Show, Eq) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + + -- An "update" is an expression like 'r{ a.b = 12 }'. + -- + -- We don't support these (in the case Rebindable Syntax is off) yet + -- (waiting on HasField support). + putStrLn "-- updates:" + print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 } diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr new file mode 100644 index 0000000000..efe360222c --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail5.hs:17:11: + RebindableSyntax is required if OverloadedRecordUpdate is enabled. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs new file mode 100644 index 0000000000..8265f56914 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax #-} + +module Main where + +import qualified RecordDotSyntaxA as A + +main = do + let bar = A.Foo { A.foo =1 } -- A defn. Perfectly reasonable. + print $ A.foo bar -- Application of a selector. Also reasonable. + let baz = bar{A.foo = 2} -- An update with a qualified field; not supported! + print $ A.foo baz diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr new file mode 100644 index 0000000000..c53990475b --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr @@ -0,0 +1,5 @@ +[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) + [2 of 2] Compiling Main ( RecordDotSyntaxFail6.hs, RecordDotSyntaxFail6.o ) + + RecordDotSyntaxFail6.hs:10:17: + Fields cannot be qualified when OverloadedRecordUpdate is enabled diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs new file mode 100644 index 0000000000..0d3d92b431 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Main where + +import qualified RecordDotSyntaxA as A + +main = do + let bar = A.Foo { A.foo =1 } -- A defn. Perfectly reasonable. + print $ (bar.A.foo) -- A field selection where the field is qualified; parse error on input ‘A.foo’. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr new file mode 100644 index 0000000000..feee41589f --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr @@ -0,0 +1,4 @@ +[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) +[2 of 2] Compiling Main ( RecordDotSyntaxFail7.hs, RecordDotSyntaxFail7.o ) + +RecordDotSyntaxFail7.hs:9:16: parse error on input ‘A.foo’ diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs new file mode 100644 index 0000000000..3b6fcc97e2 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax#-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} + +import Prelude + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +-- 'Foo' has 'foo' field of type 'Bar' +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +instance HasField "foo" Foo Bar where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) + +-- 'Bar' has a 'bar' field of type 'Baz' +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +instance HasField "bar" Bar Baz where + hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r) + +-- 'Baz' has a 'baz' field of type 'Quux' +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +instance HasField "baz" Baz Quux where + hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r) + +-- 'Quux' has a 'quux' field of type 'Int' +data Quux = Quux { quux :: Int } deriving (Show, Eq) +-- Forget to write this type's 'HasField' instance + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + print $ a.foo.bar.baz.quux diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr new file mode 100644 index 0000000000..8bf921b79f --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr @@ -0,0 +1,25 @@ +RecordDotSyntaxFail8.hs:37:3: + Ambiguous type variable ‘a0’ arising from a use of ‘print’ + prevents the constraint ‘(Show a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. + These potential instances exist: + instance Show Ordering -- Defined in ‘GHC.Show’ + instance Show Bar -- Defined at RecordDotSyntaxFail8.hs:22:41 + instance Show Baz -- Defined at RecordDotSyntaxFail8.hs:27:42 + ...plus 27 others + ...plus N instances involving out-of-scope types + (use -fprint-potential-instances to see them all) + In the first argument of ‘($)’, namely ‘print’ + In a stmt of a 'do' block: print $ ....baz.quux + In the expression: + do let a = ... + print $ ....quux + +RecordDotSyntaxFail8.hs:37:11: + No instance for (HasField "quux" Quux a0) + arising from selecting the field ‘quux’ + In the second argument of ‘($)’, namely ‘....baz.quux’ + In a stmt of a 'do' block: print $ ....baz.quux + In the expression: + do let a = ... + print $ ....quux diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs new file mode 100644 index 0000000000..b262215215 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Foo = Foo { foo :: Int } deriving Show + +main = do + let a = Foo { foo = 42 } + let _ = a.foo :: String -- Type error. Does a.foo get underlined? + undefined diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr new file mode 100644 index 0000000000..ee15f9fc6b --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr @@ -0,0 +1,9 @@ +RecordDotSyntaxFail9.hs:7:11: + Couldn't match type ‘Int’ with ‘[Char]’ + arising from selecting the field ‘foo’ + In the expression: a.foo :: String + In a pattern binding: _ = a.foo :: String + In the expression: + do let a = ... + let _ = ... + undefined diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index 88a37ec2ba..21d66337e9 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -175,3 +175,17 @@ test('T18251e', normal, compile_fail, ['']) test('T18251f', normal, compile_fail, ['']) test('T12446', normal, compile_fail, ['']) test('T17045', normal, compile_fail, ['']) +test('RecordDotSyntaxFail0', normal, compile_fail, ['']) +test('RecordDotSyntaxFail1', normal, compile_fail, ['']) +test('RecordDotSyntaxFail2', normal, compile_fail, ['']) +test('RecordDotSyntaxFail3', normal, compile_fail, ['']) +test('RecordDotSyntaxFail4', normal, compile_fail, ['']) +test('RecordDotSyntaxFail5', normal, compile_fail, ['']) +test('RecordDotSyntaxFail6', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_fail, ['RecordDotSyntaxFail6', '']) +test('RecordDotSyntaxFail7', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_fail, ['RecordDotSyntaxFail7', '']) +test('RecordDotSyntaxFail8', normal, compile_fail, ['']) +test('RecordDotSyntaxFail9', normal, compile_fail, ['']) +test('RecordDotSyntaxFail10', normal, compile_fail, ['']) +test('RecordDotSyntaxFail11', normal, compile_fail, ['']) +test('RecordDotSyntaxFail12', normal, compile_fail, ['']) +test('RecordDotSyntaxFail13', normal, compile_fail, ['']) diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax1.hs b/testsuite/tests/parser/should_run/RecordDotSyntax1.hs new file mode 100644 index 0000000000..2d14218f83 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax1.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +-- For "higher kinded data" test. +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +-- Choice (C2a). + +import Data.Function -- for & +import Data.Functor.Identity + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +-- 'Foo' has 'foo' field of type 'Bar' +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +instance HasField "foo" Foo Bar where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) + +-- 'Bar' has a 'bar' field of type 'Baz' +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +instance HasField "bar" Bar Baz where + hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r) + +-- 'Baz' has a 'baz' field of type 'Quux' +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +instance HasField "baz" Baz Quux where + hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r) + +-- 'Quux' has a 'quux' field of type 'Int' +data Quux = Quux { quux :: Int } deriving (Show, Eq) +instance HasField "quux" Quux Int where + hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r) + +-- 'Corge' has a '&&&' field of type 'Int' +data Corge = Corge { (&&&) :: Int } deriving (Show, Eq) +instance HasField "&&&" Corge Int where + hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r) +-- Note : Dot notation is not available for fields with operator +-- names. + +-- 'Grault' has two fields 'f' and 'g' of type 'Foo'. +data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq) +instance HasField "f" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r) +instance HasField "g" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r) + +-- "Higher kinded data" +-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/) +type family H f a where + H Identity a = a + H f a = f a +data P f = P + { n :: H f String + } +-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34. +instance (a ~ H f String) => HasField "n" (P f) a where + hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + let b = Corge{ (&&&) = 12 }; + let c = Grault { + f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } } + , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } } + } + + -- A "selector" is an expression like '(.a)' or '(.a.b)'. + putStrLn "-- selectors:" + print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } } + print $ (.foo.bar.baz) a -- Quux { quux = 42 } + print $ (.foo.bar.baz.quux) a -- 42 + print $ ((&&&) b) -- 12 + -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’ + print $ getField @"&&&" b -- 12 + + -- A "selection" is an expression like 'r.a' or '(f r).a.b'. + putStrLn "-- selections:" + print $ a.foo.bar.baz.quux -- 42 + print $ a.foo.bar.baz -- Quux { quux = 42 } + print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } } + print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (const "hello") a.foo -- f r.x means f (r.x) + -- print $ f a .foo -- f r .x is illegal + print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x) + -- print $ f (g a) .foo -- f (g r) .x is illegal + print $ a.foo + & (.bar.baz.quux) -- 42 + print $ (a.foo + ).bar.baz.quux -- 42 + print $ (+) a.foo.bar.baz.quux 1 -- 43 + print $ (+) (id a).foo.bar.baz.quux 1 -- 43 + print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43 + + -- An "update" is an expression like 'r{ a.b = 12 }'. + putStrLn "-- updates:" + print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 } + print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } } + let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } } + print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } } + print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } } + print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } } + print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } } + + -- A "punned update" is an expression like 'r{ a.b }' (where it is + -- understood that 'b' is a variable binding in the environment of + -- the field update - enabled only when the extension + -- 'NamedFieldPuns' is in effect). + putStrLn "-- punned updates:" + let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } } + print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4 + f <- pure a + g <- pure a + print $ c{ f } -- 42, 1 + print $ c{ f, g } -- 42, 42 + print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4 + + putStrLn "-- misc:" + -- Higher kinded test. + let p = P { n = Just "me" } :: P Maybe + Just me <- pure p.n + putStrLn $ me diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout new file mode 100644 index 0000000000..9582e17da9 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout @@ -0,0 +1,38 @@ +-- selectors: +Bar {bar = Baz {baz = Quux {quux = 42}}} +Baz {baz = Quux {quux = 42}} +Quux {quux = 42} +42 +12 +12 +-- selections: +42 +Quux {quux = 42} +Baz {baz = Quux {quux = 42}} +Bar {bar = Baz {baz = Quux {quux = 42}}} +"hello" +"hello" +42 +42 +43 +43 +43 +-- updates: +Quux {quux = 2} +Bar {bar = Baz {baz = Quux {quux = 1}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 44}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 45}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 46}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 3}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}} +-- punned updates: +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 1}}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}} +-- misc: +me diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax2.hs b/testsuite/tests/parser/should_run/RecordDotSyntax2.hs new file mode 100644 index 0000000000..89c520009f --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax2.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoRebindableSyntax #-} + +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +data Quux = Quux { quux :: Int } deriving (Show, Eq) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + + -- A "selector" is an expression like '(.a)' or '(.a.b)'. + putStrLn "-- selectors:" + print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } } + print $ (.foo.bar.baz) a -- Quux { quux = 42 } + print $ (.foo.bar.baz.quux) a -- 42 + + -- A "selection" is an expression like 'r.a' or '(f r).a.b'. + putStrLn "-- selections:" + print $ a.foo.bar.baz.quux -- 42 + print $ a.foo.bar.baz -- Quux { quux = 42 } + print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } } + print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + + -- An "update" is an expression like 'r{ a.b = 12 }'. + -- + -- We don't support these (in the case Rebindable Syntax is off) yet + -- (waiting on HasField support). + -- + -- Regular updates are fine though! + print $ a{foo=(foo a){bar = (bar (foo a)){baz = (baz (bar (foo a))){quux = quux (baz (bar (foo a))) + 1}}}} + print $ a{foo=(a.foo){bar = (a.foo.bar){baz = (a.foo.bar.baz){quux = a.foo.bar.baz.quux + 1}}}} diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout new file mode 100644 index 0000000000..6755663e6a --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout @@ -0,0 +1,12 @@ +-- selectors: +Bar {bar = Baz {baz = Quux {quux = 42}}} +Baz {baz = Quux {quux = 42}} +Quux {quux = 42} +42 +-- selections: +42 +Quux {quux = 42} +Baz {baz = Quux {quux = 42}} +Bar {bar = Baz {baz = Quux {quux = 42}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 43}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 43}}}} diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax3.hs b/testsuite/tests/parser/should_run/RecordDotSyntax3.hs new file mode 100644 index 0000000000..1ee7565573 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax3.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Main where + +import qualified RecordDotSyntaxA as A + + +main = do + print $ id A.n -- Foo {foo = 2}; f M.x means f (M.x) + print $ id A.n.foo -- 2; f M.n.x means f (M.n.x) + + let bar = A.Foo {A.foo = 1} + print $ bar.foo -- Ok; 1 + -- print $ bar.A.foo -- parse error on input 'A.foo' diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout new file mode 100644 index 0000000000..0de59d2464 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout @@ -0,0 +1,3 @@ +Foo {foo = 2} +2 +1 diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax4.hs b/testsuite/tests/parser/should_run/RecordDotSyntax4.hs new file mode 100644 index 0000000000..924ed03bde --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax4.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Main where + +import qualified RecordDotSyntaxA as A + +main = do + let bar = A.Foo {A.foo = 1} + print $ bar{A.foo = 2} -- Qualified labels ok in regular updates. diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout new file mode 100644 index 0000000000..43c812f394 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout @@ -0,0 +1 @@ +Foo {foo = 2} diff --git a/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs b/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs new file mode 100644 index 0000000000..907d6a23f6 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs @@ -0,0 +1,6 @@ +module RecordDotSyntaxA where + +data Foo = Foo { foo :: Int } deriving Show + +n :: Foo +n = Foo {foo = 2} diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T index 064ef8fffd..caf0e2bc65 100644 --- a/testsuite/tests/parser/should_run/all.T +++ b/testsuite/tests/parser/should_run/all.T @@ -23,3 +23,7 @@ test('CountParserDeps', compile_and_run, ['-package ghc']) test('LexNegLit', normal, compile_and_run, ['']) +test('RecordDotSyntax1', normal, compile_and_run, ['']) +test('RecordDotSyntax2', normal, compile_and_run, ['']) +test('RecordDotSyntax3', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_and_run, ['RecordDotSyntax3', '']) +test('RecordDotSyntax4', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_and_run, ['RecordDotSyntax4', '']) diff --git a/utils/haddock b/utils/haddock -Subproject 8241d9e700e043b86b609c334494c4632848389 +Subproject 65868397a59e61b575c70c0757dddbbba9cb5ac |