diff options
author | Shayne Fletcher <shayne@shaynefletcher.org> | 2021-05-15 21:15:41 +1000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-05-19 23:40:12 -0400 |
commit | d48b7e5c2fae5db1973a767be45aba82b2aa727c (patch) | |
tree | b0af0b799854da5e4b9efbe29a24e02d4db71641 /compiler/GHC | |
parent | df4a0a53691cd833f54eb443401243dd9c964196 (diff) | |
download | haskell-d48b7e5c2fae5db1973a767be45aba82b2aa727c.tar.gz |
Changes to HsRecField'
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Hs/Instances.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Hs/Pat.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Hs/Utils.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match/Constructor.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Pmc/Desugar.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Parser.y | 4 | ||||
-rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/Rename/Expr.hs | 20 | ||||
-rw-r--r-- | compiler/GHC/Rename/Pat.hs | 54 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 62 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Pat.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl/Utils.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 18 | ||||
-rw-r--r-- | compiler/GHC/ThToHs.hs | 20 |
22 files changed, 156 insertions, 154 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 776e1cb8b5..9b409f4232 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -1892,6 +1892,8 @@ type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL +type instance Anno (FieldLabelStrings (GhcPass p)) = SrcSpan + instance (Anno a ~ SrcSpanAnn' (EpAnn an)) => WrapXRec (GhcPass p) a where wrapXRec = noLocA diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 68b55196ca..db7af75d9b 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -426,7 +426,7 @@ deriving instance Data ConPatTc deriving instance Data ListPatTc -deriving instance (Data a, Data b) => Data (HsRecField' a b) +deriving instance (Data a, Data b) => Data (HsFieldBind a b) deriving instance (Data body) => Data (HsRecFields GhcPs body) deriving instance (Data body) => Data (HsRecFields GhcRn body) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 577321ea0a..1b9b7817e0 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -28,7 +28,7 @@ module GHC.Hs.Pat ( ConLikeP, HsConPatDetails, hsConPatArgs, - HsRecFields(..), HsRecField'(..), LHsRecField', + HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, @@ -51,7 +51,7 @@ module GHC.Hs.Pat ( import GHC.Prelude import Language.Haskell.Syntax.Pat -import Language.Haskell.Syntax.Expr (HsExpr, SyntaxExpr) +import Language.Haskell.Syntax.Expr (SyntaxExpr) import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice) @@ -156,7 +156,7 @@ type instance ConLikeP GhcPs = RdrName -- IdP GhcPs type instance ConLikeP GhcRn = Name -- IdP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XHsRecField _ = EpAnn [AddEpAnn] +type instance XHsFieldBind _ = EpAnn [AddEpAnn] -- --------------------------------------------------------------------- @@ -216,17 +216,17 @@ data CoPat co_pat_ty :: Type } -hsRecFieldId :: HsRecField GhcTc arg -> Located Id +hsRecFieldId :: HsRecField GhcTc arg -> Id hsRecFieldId = hsRecFieldSel hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName -hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl +hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hfbLHS -hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id +hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc -hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc -hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl +hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc +hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS {- @@ -684,12 +684,4 @@ collectEvVarsPat pat = type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA type instance Anno (HsOverLit (GhcPass p)) = SrcSpan type instance Anno ConLike = SrcSpanAnnN - -type instance Anno (HsRecField' p arg) = SrcSpanAnnA -type instance Anno (HsRecField' (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA -type instance Anno (HsRecField (GhcPass p) arg) = SrcSpanAnnA - --- type instance Anno (HsRecUpdField p) = SrcSpanAnnA -type instance Anno (HsRecField' (AmbiguousFieldOcc p) (LocatedA (HsExpr p))) = SrcSpanAnnA - -type instance Anno (AmbiguousFieldOcc GhcTc) = SrcSpanAnnA +type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index b4553e2ec4..c3b83eefe8 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -51,7 +51,7 @@ module GHC.Hs.Type ( HsConDetails(..), noTypeArgs, FieldOcc(..), LFieldOcc, mkFieldOcc, - AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, + AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc, rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, @@ -823,6 +823,10 @@ instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc +instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprPrefixOcc . unLoc + mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr @@ -1239,4 +1243,6 @@ type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA type instance Anno HsIPName = SrcSpan type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA + type instance Anno (FieldOcc (GhcPass p)) = SrcSpan +type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcSpan diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 68d6c9ca94..524071154f 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1600,8 +1600,8 @@ lPatImplicits = hs_lpat [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] ++ hs_lpats explicit_pats - where implicit_pats = map (hsRecFieldArg . unLoc) implicit - explicit_pats = map (hsRecFieldArg . unLoc) explicit + where implicit_pats = map (hfbRHS . unLoc) implicit + explicit_pats = map (hfbRHS . unLoc) explicit (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 4f9b85a53f..e2aa7607b6 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -993,11 +993,11 @@ addTickHsRecordBinds (HsRecFields fields dd) = do { fields' <- mapM addTickHsRecField fields ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' GhcTc id (LHsExpr GhcTc) - -> TM (LHsRecField' GhcTc id (LHsExpr GhcTc)) -addTickHsRecField (L l (HsRecField x id expr pun)) +addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc) + -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc)) +addTickHsRecField (L l (HsFieldBind x id expr pun)) = do { expr' <- addTickLHsExpr expr - ; return (L l (HsRecField x id expr' pun)) } + ; return (L l (HsFieldBind x id expr' pun)) } addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) = diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 4fb61136a2..75e72d6d9c 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -632,7 +632,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields -- else we shadow other uses of the record selector -- Hence 'lcl_id'. Cf #2735 ds_field (L _ rec_field) - = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + = do { rhs <- dsLExpr (hfbRHS rec_field) ; let fld_id = unLoc (hsRecUpdFieldId rec_field) ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id) ; return (idName fld_id, lcl_id, rhs) } @@ -818,8 +818,8 @@ dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel - = [hsRecFieldArg fld | L _ fld <- rbinds - , sel == idName (unLoc $ hsRecFieldId fld) ] + = [hfbRHS fld | L _ fld <- rbinds + , sel == idName (hsRecFieldId fld) ] {- %-------------------------------------------------------------------- diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 38d9c2101d..f8ba578775 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -577,9 +577,9 @@ push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args)) PrefixCon ts [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf - , HsRecField { hsRecFieldArg = arg } <- fld + , HsFieldBind { hfbRHS = arg } <- fld = assert (null flds) $ - RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + RecCon (rf { rec_flds = [L lf (fld { hfbRHS = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index 526614d933..303ca416d2 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -223,7 +223,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct where fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env - (idName (unLoc (hsRecFieldId rpat))) + (idName (hsRecFieldId rpat)) select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" ----------------- @@ -239,7 +239,7 @@ same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields flds1 flds2 = all2 (\(L _ f1) (L _ f2) - -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) + -> hsRecFieldId f1 == hsRecFieldId f2) (rec_flds flds1) (rec_flds flds2) @@ -263,7 +263,7 @@ conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) | null rpats = map WildPat (map scaledThing arg_tys) -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all - | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats + | otherwise = map (unLoc . hfbRHS . unLoc) rpats {- Note [Record patterns] diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index 4c9e043c25..c835832702 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -287,7 +287,7 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case -- LHsRecField rec_field_ps fs = map (tagged_pat . unLoc) fs where - tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hsRecFieldArg f) + tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hfbRHS f) -- Unfortunately the label info is empty when the DataCon wasn't defined -- with record field labels, hence we desugar to field index. orig_lbls = map flSelector $ conLikeFieldLabels con diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index b911eea798..50e8458726 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1707,17 +1707,17 @@ repFields (HsRecFields { rec_flds = flds }) where rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.FieldExp)) - rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) - ; e <- repLE (hsRecFieldArg fld) + rep_fld (L _ fld) = do { fn <- lookupOcc (hsRecFieldSel fld) + ; e <- repLE (hfbRHS fld) ; repFieldExp fn e } repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) repUpdFields = repListM fieldExpTyConName rep_fld where rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp)) - rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of + rep_fld (L l fld) = case unLoc (hfbLHS fld) of Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) - ; e <- repLE (hsRecFieldArg fld) + ; e <- repLE (hfbRHS fld) ; repFieldExp fn e } Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld) @@ -2068,8 +2068,8 @@ repP (ConPat NoExtField dc details) } where rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat))) - rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) - ; MkC p <- repLP (hsRecFieldArg fld) + rep_fld (L _ fld) = do { MkC v <- lookupOcc (hsRecFieldSel fld) + ; MkC p <- repLP (hfbRHS fld) ; rep2 fieldPatName [v,p] } repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l ; repPlit a } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index ccc99696d8..573cba529d 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1038,10 +1038,10 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a where - go :: RScoped (LocatedA (HsRecField' id a1)) - -> LocatedA (HsRecField' id (PScoped a1)) -- AZ - go (RS fscope (L spn (HsRecField x lbl pat pun))) = - L spn $ HsRecField x lbl (PS rsp scope fscope pat) pun + go :: RScoped (LocatedA (HsFieldBind id a1)) + -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ + go (RS fscope (L spn (HsFieldBind x lbl pat pun))) = + L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun scoped_fds = listScopes pscope fds instance ToHie (TScoped (HsPatSigType GhcRn)) where @@ -1333,12 +1333,12 @@ instance ( ToHie arg , HasLoc arg , Data arg , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields -instance ( ToHie (RFContext (Located label)) +instance ( ToHie (RFContext label) , ToHie arg, HasLoc arg, Data arg , Data label - ) => ToHie (RContext (LocatedA (HsRecField' label arg))) where + ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of - HsRecField _ label expr _ -> + HsFieldBind _ label expr _ -> [ toHie $ RFC c (getRealSpan $ loc expr) label , toHie expr ] diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 26f6e8b836..f9f7acc0fa 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -3365,13 +3365,13 @@ fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) } fbind :: { forall b. DisambECP b => PV (Fbind b) } : qvar '=' texp { unECP $3 >>= \ $3 -> - fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsRecField (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1N $1 $ mkFieldOcc $1) $3 False) } + fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsFieldBind (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1N $1 $ mkFieldOcc $1) $3 False) } -- RHS is a 'texp', allowing view patterns (#6038) -- and, incidentally, sections. Eg -- f (R { x = show -> s }) = ... | qvar { placeHolderPunRhs >>= \rhs -> - fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsRecField (EpAnn (glNR $1) [] cs) (sL1N $1 $ mkFieldOcc $1) rhs True) } + fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsFieldBind (EpAnn (glNR $1) [] cs) (sL1N $1 $ mkFieldOcc $1) rhs True) } -- In the punning case, use a place-holder -- The renamer fills in the final value diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index c6ad4db6d1..2eba1fa9e2 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1158,8 +1158,8 @@ pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) -checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld) - return (L l (fld { hsRecFieldArg = p })) +checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld) + return (L l (fld { hfbRHS = p })) patFail :: SrcSpan -> SDoc -> PV a patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc @@ -2411,7 +2411,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do , rupd_flds = Left fs' } True -> do let qualifiedFields = - [ L l lbl | L _ (HsRecField _ (L l lbl) _ _) <- fs' + [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' , isQual . rdrNameAmbiguousFieldOcc $ lbl ] if not $ null qualifiedFields @@ -2429,7 +2429,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do -- 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 anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = + recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = -- The idea here is to convert the label to a singleton [FastString]. let f = occNameFS . rdrNameOcc $ rdr fl = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann? @@ -2454,8 +2454,8 @@ mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs , rec_dotdot = Just (L s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField noAnn (L loc (FieldOcc _ rdr)) arg pun) - = HsRecField noAnn (L loc (Unambiguous noExtField rdr)) arg pun +mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun) + = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -2972,9 +2972,9 @@ mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)] -> LHsRecProj GhcPs (LHsExpr GhcPs) mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" mkRdrProjUpdate loc (L l flds) arg isPun anns = - L loc HsRecField { - hsRecFieldAnn = anns - , hsRecFieldLbl = L l (FieldLabelStrings flds) - , hsRecFieldArg = arg - , hsRecPun = isPun + L loc HsFieldBind { + hfbAnn = anns + , hfbLHS = L l (FieldLabelStrings flds) + , hfbRHS = arg + , hfbPun = isPun } diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index e4b4b10363..d97266d7f2 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -424,8 +424,8 @@ rnExpr (RecordCon { rcon_con = con_id , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n) - rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } + rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld) + ; return (L l (fld { hfbRHS = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) = case rbinds of @@ -437,7 +437,7 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) 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] + ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] ; punsEnabled <-xoptM LangExt.RecordPuns ; unless (null punnedFields || punsEnabled) $ addErr $ text "For this to work enable NamedFieldPuns." @@ -2618,7 +2618,7 @@ mkProjection _ _ [] = panic "mkProjection: The impossible happened" -- 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 } )) +mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } )) = let { ; flds = map (fmap (unLoc . hflLabel)) flds' ; final = last flds -- quux @@ -2643,9 +2643,11 @@ rnHsUpdProjs us = do pure (u, plusFVs fvs) where rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars) - rnRecUpdProj (L l (HsRecField _ fs arg pun)) + rnRecUpdProj (L l (HsFieldBind _ fs arg pun)) = do { (arg, fv) <- rnLExpr arg - ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn - , hsRecFieldLbl = fmap rnFieldLabelStrings fs - , hsRecFieldArg = arg - , hsRecPun = pun}), fv) } + ; return $ + (L l (HsFieldBind { + hfbAnn = noAnn + , hfbLHS = fmap rnFieldLabelStrings fs + , hfbRHS = arg + , hfbPun = pun}), fv ) } diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index c86e3f6ec2..8681903590 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -590,15 +590,15 @@ rnHsRecPatsAndThen mk (L _ con) where mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n) rn_field (L l fld, n') = - do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' })) } + do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld) + ; return (L l (fld { hfbRHS = arg' })) } loc = maybe noSrcSpan getLoc dd -- Get the arguments of the implicit binders implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats where - implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs) + implicit_pats = map (hfbRHS . unLoc) (drop n fs) -- Don't warn for let P{..} = ... in ... check_unused_wildcard = case mk of @@ -659,11 +659,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg) -> RnM (LHsRecField GhcRn (LocatedA arg)) rn_fld pun_ok parent (L l - (HsRecField - { hsRecFieldLbl = + (HsFieldBind + { hfbLHS = (L loc (FieldOcc _ (L ll lbl))) - , hsRecFieldArg = arg - , hsRecPun = pun })) + , hfbRHS = arg + , hfbPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun then do { checkErr pun_ok (badPun (L loc lbl)) @@ -671,11 +671,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) } else return arg - ; return (L l (HsRecField - { hsRecFieldAnn = noAnn - , hsRecFieldLbl = (L loc (FieldOcc sel (L ll lbl))) - , hsRecFieldArg = arg' - , hsRecPun = pun })) } + ; return (L l (HsFieldBind + { hfbAnn = noAnn + , hfbLHS = (L loc (FieldOcc sel (L ll lbl))) + , hfbRHS = arg' + , hfbPun = pun })) } rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat @@ -716,12 +716,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; addUsedGREs dot_dot_gres ; let locn = noAnnSrcSpan loc - ; return [ L (noAnnSrcSpan loc) (HsRecField - { hsRecFieldAnn = noAnn - , hsRecFieldLbl + ; return [ L (noAnnSrcSpan loc) (HsFieldBind + { hfbAnn = noAnn + , hfbLHS = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr)) - , hsRecFieldArg = L locn (mk_arg loc arg_rdr) - , hsRecPun = False }) + , hfbRHS = L locn (mk_arg loc arg_rdr) + , hfbPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl , let arg_rdr = mkVarUnqual (flLabel fl) ] } @@ -763,9 +763,9 @@ rnHsRecUpdFields flds where rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok dup_fields_ok (L l (HsRecField { hsRecFieldLbl = L loc f - , hsRecFieldArg = arg - , hsRecPun = pun })) + rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f + , hfbRHS = arg + , hfbPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f ; mb_sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker @@ -785,10 +785,10 @@ rnHsRecUpdFields flds in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name) AmbiguousFields -> (Ambiguous noExtField (L (noAnnSrcSpan loc) lbl), fvs) - ; return (L l (HsRecField { hsRecFieldAnn = noAnn - , hsRecFieldLbl = L loc lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } + ; return (L l (HsFieldBind { hfbAnn = noAnn + , hfbLHS = L loc lbl' + , hfbRHS = arg'' + , hfbPun = pun }), fvs') } dup_flds :: [NE.NonEmpty RdrName] -- Each list represents a RdrName that occurred more than once @@ -799,14 +799,14 @@ rnHsRecUpdFields flds getFieldIds :: [LHsRecField GhcRn arg] -> [Name] -getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds +getFieldIds flds = map (hsRecFieldSel . unLoc) flds getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] getFieldLbls flds - = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unXRec @p) flds + = map (unLoc . rdrNameFieldOcc . unXRec @p . hfbLHS . unXRec @p) flds getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] -getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds +getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds needFlagDotDot :: HsRecFieldContext -> SDoc needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 5bbf35d462..e9fbad3807 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -661,7 +661,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ -- STEP -1 See Note [Disambiguating record fields] in GHC.Tc.Gen.Head -- After this we know that rbinds is unambiguous ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty - ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds + ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds sel_ids = map selectorAmbiguousFieldOcc upd_flds -- STEP 0 @@ -1184,7 +1184,7 @@ getFixedTyVars upd_fld_occs univ_tvs cons -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Are all the fields unambiguous? = case mapM isUnambiguous rbnds of @@ -1203,7 +1203,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty where -- Extract the selector name of a field update if it is unambiguous isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) - isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of + isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of Unambiguous sel_name _ -> Just (x, sel_name) Ambiguous{} -> Nothing @@ -1249,7 +1249,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- where T does not have field x. pickParent :: RecSelParent -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) pickParent p (upd, xs) = case lookup p xs of -- Phew! The parent is valid for this field. @@ -1258,7 +1258,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- unambiguous ones shouldn't be recorded again -- (giving duplicate deprecation warnings). Just gre -> do { unless (null (tail xs)) $ do - let L loc _ = hsRecFieldLbl (unLoc upd) + let L loc _ = hfbLHS (unLoc upd) setSrcSpan loc $ addUsedGRE True gre ; lookupSelector (upd, greMangledName gre) } -- The field doesn't belong to this parent, so report @@ -1270,19 +1270,19 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Given a (field update, selector name) pair, look up the -- selector to give a field update with an unambiguous Id lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) lookupSelector (L l upd, n) = do { i <- tcLookupId n - ; let L loc af = hsRecFieldLbl upd + ; let L loc af = hfbLHS upd lbl = rdrNameAmbiguousFieldOcc af - -- ; return $ L l upd { hsRecFieldLbl + -- ; return $ L l upd { hfbLHS -- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) } - ; return $ L l HsRecField - { hsRecFieldAnn = hsRecFieldAnn upd - , hsRecFieldLbl + ; return $ L l HsFieldBind + { hfbAnn = hfbAnn upd + , hfbLHS = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) - , hsRecFieldArg = hsRecFieldArg upd - , hsRecPun = hsRecPun upd + , hfbRHS = hfbRHS upd + , hfbPun = hfbPun upd } } @@ -1332,24 +1332,24 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = f - , hsRecFieldArg = rhs })) + do_bind (L l fld@(HsFieldBind { hfbLHS = f + , hfbRHS = rhs })) = do { mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing - -- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' - -- , hsRecFieldArg = rhs' }))) } - Just (f', rhs') -> return (Just (L l (HsRecField - { hsRecFieldAnn = hsRecFieldAnn fld - , hsRecFieldLbl = f' - , hsRecFieldArg = rhs' - , hsRecPun = hsRecPun fld}))) } + -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f' + -- , hfbRHS = rhs' }))) } + Just (f', rhs') -> return (Just (L l (HsFieldBind + { hfbAnn = hfbAnn fld + , hfbLHS = f' + , hfbRHS = rhs' + , hfbPun = hfbPun fld}))) } tcRecordUpd :: ConLike -> [TcType] -- Expected type for each field - -> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -> TcM [LHsRecUpdField GhcTc] tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds @@ -1357,10 +1357,10 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds fields = map flSelector $ conLikeFieldLabels con_like flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) + do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) -> TcM (Maybe (LHsRecUpdField GhcTc)) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af - , hsRecFieldArg = rhs })) + do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af + , hfbRHS = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl)) @@ -1369,11 +1369,11 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds Nothing -> return Nothing Just (f', rhs') -> return (Just - (L l (fld { hsRecFieldLbl + (L l (fld { hfbLHS = L loc (Unambiguous (extFieldOcc (unLoc f')) (L (noAnnSrcSpan loc) lbl)) - , hsRecFieldArg = rhs' }))) } + , hfbRHS = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn @@ -1471,7 +1471,7 @@ badFieldTypes prs 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) badFieldsUpd - :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to -> SDoc @@ -1507,7 +1507,7 @@ badFieldsUpd rbinds data_cons membership :: [(FieldLabelString, [Bool])] membership = sortMembership $ map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $ - map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds + map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds fieldLabelSets :: [UniqSet FieldLabelString] fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons @@ -1594,7 +1594,7 @@ noPossibleParents rbinds = hang (text "No type has all these fields:") 2 (pprQuotedList fields) where - fields = map (hsRecFieldLbl . unLoc) rbinds + fields = map (hfbLHS . unLoc) rbinds badOverloadedUpdate :: SDoc badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index f836d809f3..536baa278f 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -1245,13 +1245,13 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTc (LPat GhcTc)) tc_field penv - (L l (HsRecField ann (L loc (FieldOcc sel (L lr rdr))) pat pun)) + (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun)) thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside - ; return (L l (HsRecField ann (L loc (FieldOcc sel' (L lr rdr))) pat' + ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat' pun), res) } diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 400a4d770a..d659b4e8d9 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -1223,7 +1223,7 @@ tcCollectEx pat = go pat = mergeMany . map goRecFd $ flds goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p + goRecFd (L _ HsFieldBind{ hfbRHS = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) mergeMany = foldr merge empty diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 79ed91ba30..9e13a632ae 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -920,14 +920,14 @@ mkOneRecordSelector all_cons idDetails fl has_sel (L loc' (HsVar noExtField (L locn field_var))) mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLocA (HsRecField - { hsRecFieldAnn = noAnn - , hsRecFieldLbl + rec_field = noLocA (HsFieldBind + { hfbAnn = noAnn + , hfbLHS = L loc (FieldOcc sel_name (L locn $ mkVarUnqual lbl)) - , hsRecFieldArg + , hfbRHS = L loc' (VarPat noExtField (L locn field_var)) - , hsRecPun = False }) + , hfbPun = False }) sel_lname = L locn sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 7215e09d96..c20bb08aac 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1377,10 +1377,10 @@ zonkRecFields env (HsRecFields flds dd) ; return (HsRecFields flds' dd) } where zonk_rbind (L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = new_id - , hsRecFieldArg = new_expr })) } + = do { new_id <- wrapLocM (zonkFieldOcc env) (hfbLHS fld) + ; new_expr <- zonkLExpr env (hfbRHS fld) + ; return (L l (fld { hfbLHS = new_id + , hfbRHS = new_expr })) } zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc] -> TcM [LHsRecUpdField GhcTc] @@ -1388,9 +1388,9 @@ zonkRecUpdFields env = mapM zonk_rbind where zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } + ; new_expr <- zonkLExpr env (hfbRHS fld) + ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id + , hfbRHS = new_expr })) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a @@ -1563,9 +1563,9 @@ zonkConStuff env (InfixCon p1 p2) ; return (env', InfixCon p1' p2') } zonkConStuff env (RecCon (HsRecFields rpats dd)) - = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) + = do { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats) ; let rpats' = zipWith (\(L l rp) p' -> - L l (rp { hsRecFieldArg = p' })) + L l (rp { hfbRHS = p' })) rpats pats' ; return (env', RecCon (HsRecFields rpats' dd)) } -- Field selectors have declared types; hence no zonking diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 02b93c5803..f8efa8f28d 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1082,13 +1082,13 @@ which we don't want. -} cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) - -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs)) + -> CvtM (LHsFieldBind GhcPs (Located t) (LHsExpr GhcPs)) cvtFld f (v,e) = do { v' <- vNameL v; e' <- cvtl e - ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn - , hsRecFieldLbl = reLoc $ fmap f v' - , hsRecFieldArg = e' - , hsRecPun = False}) } + ; return (noLocA $ HsFieldBind { hfbAnn = noAnn + , hfbLHS = reLoc $ fmap f v' + , hfbRHS = e' + , hfbPun = False}) } cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } @@ -1361,11 +1361,11 @@ cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) = do { L ls s' <- vNameN s ; p' <- cvtPat p - ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn - , hsRecFieldLbl - = L (locA ls) $ mkFieldOcc (L ls s') - , hsRecFieldArg = p' - , hsRecPun = False}) } + ; return (noLocA $ HsFieldBind { hfbAnn = noAnn + , hfbLHS + = L (locA ls) $ mkFieldOcc (L ls s') + , hfbRHS = p' + , hfbPun = False}) } {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is. |