X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=b1a4c59a88a90aec0892c979bdabadc057db8f34;hb=3891512c4c770dadd0372ad84d2dec72b34652d2;hp=cead3dd541c119609bbc3ffbc1e0e83f90ad4cbc;hpb=58521c72cec262496dabf5fffb057d25ab17a0f7;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index cead3dd..b1a4c59 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -14,8 +14,7 @@ import Match import DsUtils import DsMonad -import HsSyn hiding (collectPatBinders, collectLocatedPatBinders, collectl, - collectPatsBinders, collectLocatedPatsBinders) +import HsSyn hiding (collectPatBinders, collectPatsBinders ) import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes @@ -142,7 +141,7 @@ coreCasePair scrut_var var1 var2 body \begin{code} mkCorePairTy :: Type -> Type -> Type -mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2] +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] @@ -526,7 +525,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do let - defined_vars = mkVarSet (map unLoc (collectLocalBinders binds)) + defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = local_vars `unionVarSet` defined_vars (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body @@ -633,7 +632,7 @@ dsCmdDo ids local_vars env_ids res_ty [] body dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do let - bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt)) + bound_vars = mkVarSet (collectLStmtBinders stmt) local_vars' = local_vars `unionVarSet` bound_vars (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body @@ -779,7 +778,9 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> -- arr (\((xs1),(xs2)) -> (xs')) >>> ss' -dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss _binds) = do +dsCmdStmt ids local_vars env_ids out_ids + (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_rec_rets = rhss, recS_dicts = _binds }) = do let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ******** env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_ids = varSetElems env2_id_set @@ -921,7 +922,7 @@ dsCmdStmts ids local_vars env_ids out_ids [stmt] dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do let - bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt)) + bound_vars = mkVarSet (collectLStmtBinders stmt) local_vars' = local_vars `unionVarSet` bound_vars (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt @@ -961,10 +962,10 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` - mkVarSet (map unLoc (collectLocalBinders binds)) + mkVarSet (collectLocalBinders binds) in [(expr, - mkVarSet (map unLoc (collectLStmtsBinders stmts)) + mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) | L _ (GRHS stmts expr) <- grhss] \end{code} @@ -1007,6 +1008,8 @@ foldb f xs = foldb f (fold_pairs xs) fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs \end{code} +Note [Dictionary binders in ConPatOut] See also same Note in HsUtils +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following functions to collect value variables from patterns are copied from HsUtils, with one change: we also collect the dictionary bindings (pat_binds) from ConPatOut. We need them for cases like @@ -1027,29 +1030,24 @@ these bindings. \begin{code} collectPatBinders :: OutputableBndr a => LPat a -> [a] -collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) - -collectLocatedPatBinders :: OutputableBndr a => LPat a -> [Located a] -collectLocatedPatBinders pat = collectl pat [] +collectPatBinders pat = collectl pat [] collectPatsBinders :: OutputableBndr a => [LPat a] -> [a] -collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) - -collectLocatedPatsBinders :: OutputableBndr a => [LPat a] -> [Located a] -collectLocatedPatsBinders pats = foldr collectl [] pats +collectPatsBinders pats = foldr collectl [] pats --------------------- -collectl :: OutputableBndr a => LPat a -> [Located a] -> [Located a] -collectl (L l pat) bndrs +collectl :: OutputableBndr a => LPat a -> [a] -> [a] +-- See Note [Dictionary binders in ConPatOut] +collectl (L _ pat) bndrs = go pat where - go (VarPat var) = L l var : bndrs - go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs + go (VarPat var) = var : bndrs + go (VarPatOut var bs) = var : collectHsBindsBinders bs ++ bndrs go (WildPat _) = bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs - go (AsPat a pat) = a : collectl pat bndrs + go (AsPat (L _ a) pat) = a : collectl pat bndrs go (ParPat pat) = collectl pat bndrs go (ListPat pats _) = foldr collectl bndrs pats @@ -1058,11 +1056,11 @@ collectl (L l pat) bndrs go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = - collectHsBindLocatedBinders ds + collectHsBindsBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _) = bndrs go (NPat _ _ _) = bndrs - go (NPlusKPat n _ _ _) = n : bndrs + go (NPlusKPat (L _ n) _ _ _) = n : bndrs go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs