@@ -93,8 +93,14 @@ eval stk env rec defs (LProj exp i)
9393eval stk env rec defs (LCon loc i n es)
9494 = unload stk <$> (LCon loc i n <$> mapM (eval [] env rec defs) es)
9595eval stk env rec defs (LCase ty e alts)
96− = LCase ty <$> eval [] env rec defs e
97− <*> mapM (evalAlt stk env rec defs) alts
96+ = do alts' <- mapM (evalAlt stk env rec defs) alts
97+ e' <- eval [] env rec defs e
98+ -- If they're all lambdas, bind the lambda at the top
99+ let prefix = getLams (map getRHS alts')
100+ case prefix of
101+ [] -> return $ LCase ty e' alts'
102+ args -> do alts_red <- mapM (dropArgs args) alts'
103+ return $ LLam args (LCase ty e' alts_red)
98104eval stk env rec defs (LOp f es)
99105 = unload stk <$> LOp f <$> mapM (eval [] env rec defs) es
100106eval stk env rec defs (LForeign t s args)
@@ -136,6 +142,37 @@ evalAlt stk env rec defs (LConstCase c e)
136142evalAlt stk env rec defs (LDefaultCase e)
137143 = LDefaultCase <$> eval stk env rec defs e
138144
145+dropArgs :: [Name] -> LAlt -> State Int LAlt
146+dropArgs as (LConCase i n es (LLam args rhs))
147+ = do let old = take (length as) args
148+ rhs' <- eval [] (zipWith (\ o n -> (o, LV n)) old as) [] emptyContext rhs
149+ return (LConCase i n es rhs')
150+dropArgs as (LConstCase c (LLam args rhs))
151+ = do let old = take (length as) args
152+ rhs' <- eval [] (zipWith (\ o n -> (o, LV n)) old as) [] emptyContext rhs
153+ return (LConstCase c rhs')
154+dropArgs as (LDefaultCase (LLam args rhs))
155+ = do let old = take (length as) args
156+ rhs' <- eval [] (zipWith (\ o n -> (o, LV n)) old as) [] emptyContext rhs
157+ return (LDefaultCase rhs')
158+
159+-- dropArgs as (LConstCase c rhs) = LConstCase c (dropRHS as rhs)
160+-- dropArgs as (LDefaultCase rhs) = LDefaultCase (dropRHS as rhs)
161+
162+getRHS (LConCase i n es rhs) = rhs
163+getRHS (LConstCase _ rhs) = rhs
164+getRHS (LDefaultCase rhs) = rhs
165+
166+getLams [] = []
167+getLams (LLam args tm : cs) = getLamPrefix args cs
168+getLams _ = []
169+
170+getLamPrefix as [] = as
171+getLamPrefix as (LLam args tm : cs)
172+ | length args < length as = getLamPrefix args cs
173+ | otherwise = getLamPrefix as cs
174+getLamPrefix as (_ : cs) = []
175+
139176apply :: [LExp] -> [(Name, LExp)] -> [Name] -> LDefs -> LExp ->
140177 [Name] -> LExp -> State Int LExp
141178apply stk env rec defs var args body