Transfer: don't eta-expand overshadowed constructors.

1 files changed, 12 insertions, 7 deletions

diff --git a/src/Transfer/SyntaxToCore.hs b/src/Transfer/SyntaxToCore.hs
index 23c2328a2..a46544a8f 100644
--- a/src/Transfer/SyntaxToCore.hs
+++ b/src/Transfer/SyntaxToCore.hs
@@ -186,22 +186,27 @@ argumentTypes e = case e of
 
 -- | Fix up constructor patterns and applications.
 replaceCons :: [Decl] -> C [Decl]
-replaceCons ds = mapM f ds
+replaceCons ds = mapM (f cs) ds
   where
   cs = consArities ds 
-  isCons id = id `Map.member` cs 
-  f :: Tree a -> C (Tree a)
-  f t = case t of
+  f :: DataConsInfo -> Tree a -> C (Tree a)
+  f cs x = case x of
         -- get rid of the PConsTop hack
-        PConsTop id p1 ps -> f (PCons id (p1:ps))
+        PConsTop id p1 ps -> f cs (PCons id (p1:ps))
         -- replace patterns C where C is a constructor with (C)
         PVar id | isCons id -> return $ PCons id []
+        -- don't eta-expand overshadowed constructors
+        EAbs (VVar id) e | isCons id -> 
+                  liftM (EAbs (VVar id)) (f (Map.delete id cs) e)
+        EPi (VVar id) t e | isCons id -> 
+                  liftM2 (EPi (VVar id)) (f cs t) (f (Map.delete id cs) e)
         -- eta-expand constructors. betaReduce will remove any beta 
         -- redexes produced here.
         EVar id | isCons id -> do
                                let Just n = Map.lookup id cs
-                               abstract n (apply t)
-        _ -> composOpM f t
+                               abstract n (apply x)
+        _ -> composOpM (f cs) x
+    where isCons = (`Map.member` cs)
 
 --
 -- * Do simple beta reductions.