diff options
Diffstat (limited to 'compiler/deSugar/DsExpr.hs')
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 26 |
1 files changed, 13 insertions, 13 deletions
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index fe528a143a..d91ccfbc6c 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -499,11 +499,11 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do -- A newtype in the corner should be opaque; -- hence TcType.tcSplitFunTys - mk_arg (arg_ty, lbl) -- Selector id has the field label as its name - = case findField (rec_flds rbinds) lbl of + mk_arg (arg_ty, fl) + = case findField (rec_flds rbinds) (flSelector fl) of (rhs:rhss) -> ASSERT( null rhss ) dsLExpr rhs - [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl) + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty labels = dataConFieldLabels (idDataCon data_con_id) @@ -550,7 +550,7 @@ But if x::T a b, then So we need to cast (T a Int) to (T a b). Sigh. -} -dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) +dsExpr expr@(RecordUpd record_expr fields cons_to_upd in_inst_tys out_inst_tys) | null fields = dsLExpr record_expr @@ -576,13 +576,13 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ; return (add_field_binds field_binds' $ bindNonRec discrim_var record_expr' matching_code) } where - ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr) + ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr) -- Clone the Id in the HsRecField, because its Name is that - -- of the record selector, and we must not make that a lcoal binder + -- of the record selector, and we must not make that a local binder -- else we shadow other uses of the record selector -- Hence 'lcl_id'. Cf Trac #2735 ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) - ; let fld_id = unLoc (hsRecFieldId rec_field) + ; let fld_id = unLoc (hsRecUpdFieldId rec_field) ; lcl_id <- newSysLocalDs (idType fld_id) ; return (idName fld_id, lcl_id, rhs) } @@ -606,8 +606,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids - mk_val_arg field_name pat_arg_id - = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id) + mk_val_arg fl pat_arg_id + = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) -- Reconstruct with the WrapId so that unpacking happens wrap = mkWpEvVarApps theta_vars <.> @@ -684,13 +684,13 @@ dsExpr (EViewPat {}) = panic "dsExpr:EViewPat" dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat" dsExpr (HsType {}) = panic "dsExpr:HsType" dsExpr (HsDo {}) = panic "dsExpr:HsDo" - +dsExpr (HsSingleRecFld{}) = panic "dsExpr: HsSingleRecFld" findField :: [LHsRecField Id arg] -> Name -> [arg] -findField rbinds lbl - = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds - , lbl == idName (unLoc id) ] +findField rbinds sel + = [hsRecFieldArg fld | L _ fld <- rbinds + , sel == idName (unLoc $ hsRecFieldId fld) ] {- %-------------------------------------------------------------------- |