X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=7f798f81f79c55001e6043afe74c7d745e4148bd;hp=46a80491ea663b0abc45ee3dac724c642644d2cd;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=682cf829945240fffc199bee3fe469131d5bf4b8 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 46a8049..7f798f8 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -6,13 +6,6 @@ Desugaring arrow commands \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module DsArrows ( dsProcExpr ) where #include "HsVersions.h" @@ -21,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 @@ -37,16 +29,17 @@ import Type import CoreSyn import CoreFVs import CoreUtils +import MkCore -import Id import Name -import PrelInfo +import Var +import Id import DataCon import TysWiredIn import BasicTypes import PrelNames -import Util - +import Outputable +import Bag import VarSet import SrcLoc @@ -147,7 +140,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] @@ -155,7 +148,7 @@ mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] The input is divided into a local environment, which is a flat tuple (unless it's too big), and a stack, each element of which is paired -with the stack in turn. In general, the input has the form +with the environment in turn. In general, the input has the form (...((x1,...,xn),s1),...sk) @@ -222,16 +215,11 @@ matchVarStack env_id (stack_id:stack_ids) body = do \end{code} \begin{code} -mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id -mkHsTupleExpr [e] = e -mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed - -mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id -mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2] - -mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id +mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id mkHsEnvStackExpr env_ids stack_ids - = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids) + = foldl (\a b -> mkLHsTupleExpr [a,b]) + (mkLHsVarTuple env_ids) + (map nlHsVar stack_ids) \end{code} Translation of arrow abstraction @@ -251,7 +239,7 @@ dsProcExpr dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do meth_ids <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) - (core_cmd, free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd + (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids fail_expr <- mkFailExpr ProcExpr env_ty var <- selectSimpleMatchVarL pat @@ -261,6 +249,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do (Lam var match_code) core_cmd return (bindCmdEnv meth_ids proc_code) +dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c) \end{code} Translation of command judgements of the form @@ -268,6 +257,8 @@ Translation of command judgements of the form A | xs |- c :: [ts] t \begin{code} +dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id + -> DsM (CoreExpr, IdSet) dsLCmd ids local_vars env_ids stack res_ty cmd = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd) @@ -294,7 +285,6 @@ dsCmd ids local_vars env_ids stack res_ty let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - env_ty = mkBigCoreVarTupTy env_ids core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg stack_ids <- mapM newSysLocalDs stack @@ -320,7 +310,6 @@ dsCmd ids local_vars env_ids stack res_ty let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - env_ty = mkBigCoreVarTupTy env_ids core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg @@ -415,7 +404,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- c1 ||| c2 -dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do +dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do core_cond <- dsLExpr cond (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd @@ -423,20 +412,26 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName - let - left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e] - right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e] + + let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e] + mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e] in_ty = envStackType env_ids stack then_ty = envStackType then_ids stack else_ty = envStackType else_ids stack sum_ty = mkTyConApp either_con [then_ty, else_ty] fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars - - core_if <- matchEnvStack env_ids stack_ids - (mkIfThenElse core_cond - (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids)) - (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids))) + + core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_ids) + core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids) + + core_if <- case mb_fun of + Just fun -> do { core_fun <- dsExpr fun + ; matchEnvStack env_ids stack_ids $ + mkCoreApps core_fun [core_cond, core_left, core_right] } + Nothing -> matchEnvStack env_ids stack_ids $ + mkIfThenElse core_cond core_left core_right + return (do_map_arrow ids in_ty sum_ty res_ty core_if (do_choice ids then_ty else_ty res_ty core_then core_else), @@ -459,19 +454,17 @@ is translated to The idea is to extract the commands from the case, build a balanced tree of choices, and replace the commands with expressions that build tagged tuples, obtaining a case expression that can be desugared normally. -To build all this, we use quadruples decribing segments of the list of +To build all this, we use triples describing segments of the list of case bodies, containing the following fields: -1. an IdSet containing the environment variables free in the case bodies -2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put + * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put into the case replacing the commands -3. a sum type that is the common type of these expressions, and also the + * a sum type that is the common type of these expressions, and also the input type of the arrow -4. a CoreExpr for an arrow built by combining the translated command + * a CoreExpr for an arrow built by combining the translated command bodies with |||. \begin{code} dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = do - core_exp <- dsLExpr exp stack_ids <- mapM newSysLocalDs stack -- Extract and desugar the leaf commands in the case, building tuple @@ -480,10 +473,9 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ let leaves = concatMap leavesMatch matches make_branch (leaf, bound_vars) = do - (core_leaf, fvs, leaf_ids) <- + (core_leaf, _fvs, leaf_ids) <- dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf - return (fvs `minusVarSet` bound_vars, - [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids], + return ([mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) @@ -500,22 +492,19 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. - merge_branches (fvs1, builds1, in_ty1, core_exp1) - (fvs2, builds2, in_ty2, core_exp2) - = (fvs1 `unionVarSet` fvs2, - map (left_expr in_ty1 in_ty2) builds1 ++ + merge_branches (builds1, in_ty1, core_exp1) + (builds2, in_ty2, core_exp2) + = (map (left_expr in_ty1 in_ty2) builds1 ++ map (right_expr in_ty1 in_ty2) builds2, mkTyConApp either_con [in_ty1, in_ty2], do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) - (fvs_alts, leaves', sum_ty, core_choices) - = foldb merge_branches branches + (leaves', sum_ty, core_choices) = foldb merge_branches branches -- Replace the commands in the case with these tagged tuples, -- yielding a HsExpr Id we can feed to dsExpr. (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack - fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars pat_ty = funArgTy match_ty match_ty' = mkFunTy pat_ty sum_ty @@ -525,7 +514,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty')) core_matches <- matchEnvStack env_ids stack_ids core_body return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - fvs_exp `unionVarSet` fvs_alts) + exprFreeVars core_body `intersectVarSet` local_vars) -- A | ys |- c :: [ts] t -- ---------------------------------- @@ -535,10 +524,10 @@ 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 + (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body stack_ids <- mapM newSysLocalDs stack -- build a new environment, plus the stack, using the let bindings core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids) @@ -552,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do core_body, exprFreeVars core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _) - = dsCmdDo ids local_vars env_ids res_ty stmts body +dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _) + = dsCmdDo ids local_vars env_ids res_ty stmts -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t -- A | xs |- ci :: [tsi] ti @@ -573,6 +562,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr) = do expr2 <- mkTickBox ix vars expr1 return (expr2,id_set) +dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) + -- A | ys |- c :: [ts] t (ys <= xs) -- --------------------- -- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c @@ -627,7 +618,6 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- so don't pull on it too early -> Type -- return type of the statement -> [LStmt Id] -- statements to desugar - -> LHsExpr Id -- body -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -635,15 +625,17 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- -------------------------- -- A | xs |- do { c } :: [] t -dsCmdDo ids local_vars env_ids res_ty [] body +dsCmdDo _ _ _ _ [] = panic "dsCmdDo" + +dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)] = dsLCmd ids local_vars env_ids [] res_ty body -dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do +dsCmdDo ids local_vars env_ids res_ty (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') <- fixDs (\ ~(_,_,env_ids') -> do - (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body + (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do + (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts return (core_stmts, fv_stmts, varSetElems fv_stmts)) (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt return (do_compose ids @@ -659,6 +651,8 @@ A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. \begin{code} +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id + -> DsM (CoreExpr, IdSet) dsCmdLStmt ids local_vars env_ids out_ids cmd = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd) @@ -681,7 +675,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do +dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd core_mux <- matchEnvStack env_ids [] (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) @@ -784,8 +778,10 @@ 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 - let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ******** +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 }) = do + let env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_ids = varSetElems env2_id_set env2_ty = mkBigCoreVarTupTy env2_ids @@ -831,10 +827,14 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b return (core_body, env1_id_set `unionVarSet` env2_id_set) +dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) + -- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>> -- ss >>> -- arr (\ (out_ids) -> ((later_ids),(rhss))) >>> +dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id] + -> DsM (CoreExpr, VarSet, [Var]) dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do let rec_id_set = mkVarSet rec_ids @@ -922,9 +922,9 @@ 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_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 return (do_compose ids (mkBigCoreVarTupTy env_ids) @@ -934,6 +934,8 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do core_stmts, fv_stmt) +dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []" + \end{code} Match a list of expressions against a list of patterns, left-to-right. @@ -949,6 +951,7 @@ matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do match_code <- matchSimplys exps ctxt pats result_expr fail_expr matchSimply exp ctxt pat match_code fail_expr +matchSimplys _ _ _ _ _ = panic "matchSimplys" \end{code} List of leaf expressions, with set of variables bound in each @@ -959,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} @@ -976,7 +979,7 @@ replaceLeavesMatch -> LMatch Id -- the matches of a case command -> ([LHsExpr Id],-- remaining leaf expressions LMatch Id) -- updated match -replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) +replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in @@ -987,8 +990,9 @@ replaceLeavesGRHS -> LGRHS Id -- rhss of a case command -> ([LHsExpr Id],-- remaining leaf expressions LGRHS Id) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs)) +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) = (leaves, L loc (GRHS stmts leaf)) +replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" \end{code} Balanced fold of a non-empty list. @@ -1004,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 @@ -1023,45 +1029,49 @@ See comments in HsUtils for why the other version does not include these bindings. \begin{code} -collectPatBinders :: LPat a -> [a] -collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) - -collectLocatedPatBinders :: LPat a -> [Located a] -collectLocatedPatBinders pat = collectl pat [] - -collectPatsBinders :: [LPat a] -> [a] -collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) +collectPatBinders :: LPat Id -> [Id] +collectPatBinders pat = collectl pat [] -collectLocatedPatsBinders :: [LPat a] -> [Located a] -collectLocatedPatsBinders pats = foldr collectl [] pats +collectPatsBinders :: [LPat Id] -> [Id] +collectPatsBinders pats = foldr collectl [] pats --------------------- -collectl (L l pat) bndrs +collectl :: LPat Id -> [Id] -> [Id] +-- 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 - ++ bndrs + go (VarPat var) = var : 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 go (PArrPat pats _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats - go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = - collectHsBindLocatedBinders ds + collectEvBinders 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 - go (TypePat ty) = bndrs - go (CoPat _ pat ty) = collectl (noLoc pat) bndrs + go (CoPat _ pat _) = collectl (noLoc pat) bndrs + go (ViewPat _ pat _) = collectl pat bndrs + go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p) + +collectEvBinders :: TcEvBinds -> [Id] +collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs +collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" + +add_ev_bndr :: EvBind -> [Id] -> [Id] +add_ev_bndr (EvBind b _) bs | isId b = b:bs + | otherwise = bs + -- A worry: what about coercion variable binders?? \end{code}