X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=34a3a202bcff2336507eb5311a07135b1b98e022;hp=4163559959ba85d351f14e8a6f5a61009b05fb23;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=367b0590cc0d8ba3d1561c85b366a183b8a71d24 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 4163559..34a3a20 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -19,6 +19,7 @@ import DsListComp import DsUtils import DsArrows import DsMonad +import Name #ifdef GHCI import PrelNames @@ -40,7 +41,6 @@ import CostCentre import Id import PrelInfo import DataCon -import TyCon import TysWiredIn import BasicTypes import PrelNames @@ -104,8 +104,9 @@ ds_val_bind (NonRecursive, hsbinds) body -- below. Then pattern-match would fail. Urk.) putSrcSpanDs loc $ case bind of - FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick } - -> matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> + FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, + fun_tick = tick, fun_infix = inf } + -> matchWrapper (FunRhs (idName fun ) inf) matches `thenDs` \ (args, rhs) -> ASSERT( null args ) -- Functions aren't lifted ASSERT( isIdHsWrapper co_fn ) mkOptTickBox tick rhs `thenDs` \ rhs' -> @@ -408,7 +409,7 @@ We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. \begin{code} -dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds)) +dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = dsExpr con_expr `thenDs` \ con_expr' -> let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -416,7 +417,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds)) -- hence TcType.tcSplitFunTys mk_arg (arg_ty, lbl) -- Selector id has the field label as its name - = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of + = case findField (rec_flds rbinds) lbl of (rhs:rhss) -> ASSERT( null rhss ) dsLExpr rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl)) @@ -456,70 +457,51 @@ might do some argument-evaluation first; and may have to throw away some dictionaries. \begin{code} -dsExpr (RecordUpd record_expr (HsRecordBinds []) record_in_ty record_out_ty) +dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) + cons_to_upd in_inst_tys out_inst_tys) + | null fields = dsLExpr record_expr - -dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) record_in_ty record_out_ty) - = dsLExpr record_expr `thenDs` \ record_expr' -> - - -- Desugar the rbinds, and generate let-bindings if - -- necessary so that we don't lose sharing - - let - in_inst_tys = tcTyConAppArgs record_in_ty -- Newtype opaque - out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque - in_out_ty = mkFunTy record_in_ty record_out_ty - - mk_val_arg field old_arg_id - = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of - (rhs:rest) -> ASSERT(null rest) rhs - [] -> nlHsVar old_arg_id - - mk_alt con - = ASSERT( isVanillaDataCon con ) - newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids -> - -- This call to dataConInstOrigArgTys won't work for existentials - -- but existentials don't have record types anyway - let - val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - (dataConFieldLabels con) arg_ids - rhs = foldl (\a b -> nlHsApp a b) - (nlHsTyApp (dataConWrapId con) out_inst_tys) - val_args - in - returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs) - in - -- Record stuff doesn't work for existentials + | otherwise + = -- Record stuff doesn't work for existentials -- The type checker checks for this, but we need -- worry only about the constructors that are to be updated - ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr ) + ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr ) + + do { record_expr' <- dsLExpr record_expr + ; let -- Awkwardly, for families, the match goes + -- from instance type to family type + tycon = dataConTyCon (head cons_to_upd) + in_ty = mkTyConApp tycon in_inst_tys + in_out_ty = mkFunTy in_ty + (mkFamilyTyConApp tycon out_inst_tys) + + mk_val_arg field old_arg_id + = case findField fields field of + (rhs:rest) -> ASSERT(null rest) rhs + [] -> nlHsVar old_arg_id + + mk_alt con + = ASSERT( isVanillaDataCon con ) + do { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) + -- This call to dataConInstOrigArgTys won't work for existentials + -- but existentials don't have record types anyway + ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + (dataConFieldLabels con) arg_ids + rhs = foldl (\a b -> nlHsApp a b) + (nlHsTyApp (dataConWrapId con) out_inst_tys) + val_args + pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty + + ; return (mkSimpleMatch [pat] rhs) } -- It's important to generate the match with matchWrapper, -- and the right hand sides with applications of the wrapper Id -- so that everything works when we are doing fancy unboxing on the -- constructor aguments. - mappM mk_alt cons_to_upd `thenDs` \ alts -> - matchWrapper RecUpd (MatchGroup alts in_out_ty) `thenDs` \ ([discrim_var], matching_code) -> + ; alts <- mapM mk_alt cons_to_upd + ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty) - returnDs (bindNonRec discrim_var record_expr' matching_code) - - where - updated_fields :: [FieldLabel] - updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds] - - -- Get the type constructor from the record_in_ty - -- so that we are sure it'll have all its DataCons - -- (In GHCI, it's possible that some TyCons may not have all - -- their constructors, in a module-loop situation.) - tycon = tcTyConAppTyCon record_in_ty - data_cons = tyConDataCons tycon - cons_to_upd = filter has_all_fields data_cons - - has_all_fields :: DataCon -> Bool - has_all_fields con_id - = all (`elem` con_fields) updated_fields - where - con_fields = dataConFieldLabels con_id + ; return (bindNonRec discrim_var record_expr' matching_code) } \end{code} Here is where we desugar the Template Haskell brackets and escapes @@ -564,6 +546,11 @@ dsExpr (HsBinTick ixT ixF e) = do dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" #endif + +findField :: [HsRecField Id arg] -> Name -> [arg] +findField rbinds lbl + = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds + , lbl == idName (unLoc id) ] \end{code} %--------------------------------------------------------------------