diff options
Diffstat (limited to 'compiler/deSugar/DsExpr.lhs')
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 13 |
1 files changed, 8 insertions, 5 deletions
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 1fda49b567..546a198ca8 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -47,6 +47,7 @@ import Id import Module import VarSet import VarEnv +import ConLike import DataCon import TysWiredIn import BasicTypes @@ -98,7 +99,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds, + | [(_, L loc bind)] <- bagToList hsbinds, -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes @@ -132,7 +133,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] , abs_binds = binds }) body = do { let body1 = foldr bind_export body exports bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b - ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) + ; body2 <- foldlBagM (\body (_, bind) -> dsStrictBind (unLoc bind) body) body1 binds ; ds_binds <- dsTcEvBinds ev_binds ; return (mkCoreLets ds_binds body2) } @@ -163,7 +164,7 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ---------------------- strictMatchOnly :: HsBind Id -> Bool strictMatchOnly (AbsBinds { abs_binds = binds }) - = anyBag (strictMatchOnly . unLoc) binds + = anyBag (strictMatchOnly . unLoc . snd) binds strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) = isUnLiftedType ty || isBangLPat lpat @@ -542,11 +543,13 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] - pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs + pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con) + , pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_ty = in_ty } + , pat_ty = in_ty + , pat_wrap = idHsWrapper } ; let wrapped_rhs | null eq_spec = rhs | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs ; return (mkSimpleMatch [pat] wrapped_rhs) } |