purescript-lua · Unisay · Jun 12, 2026 · Jun 12, 2026 · Jun 12, 2026
diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs
@@ -80,7 +80,10 @@ Two consequences:
 renameShadowedNames ∷ UberModule → UberModule
 renameShadowedNames uberModule =
   uberModule
-    { uberModuleExports =
+    { uberModuleBindings =
+        fmap (renameShadowedNamesInExpr mempty)
+          <<$>> uberModuleBindings uberModule
+    , uberModuleExports =
         renameShadowedNamesInExpr mempty <<$>> uberModuleExports uberModule
     }
 
@@ -265,10 +268,10 @@ substituteInExports qname inlinee = map \case
 
 optimizedExpression ∷ Exp → Exp
 optimizedExpression =
+  -- See Note [Eta reduction is unsound]
   rewriteExpTopDown $
     constantFolding
       `thenRewrite` betaReduce
-      `thenRewrite` etaReduce
       `thenRewrite` betaReduceUnusedParams
       `thenRewrite` removeUnreachableThenBranch
       `thenRewrite` removeUnreachableElseBranch
@@ -301,14 +304,48 @@ betaReduce =
       Rewritten Recurse $ substitute (Local param) 0 r body
     _ → NoChange
 
--- (λx. M x) where x not free in M ===> M
-etaReduce ∷ RewriteRule Ann
-etaReduce =
-  pure . \case
-    Abs _ (ParamNamed _ param) (App _ m (Ref _ (Local param') 0))
-      | param == param' && countFreeRef (Local param) m == 0 →
-          Rewritten Recurse m
-    _ → NoChange
+{- Note [Eta reduction is unsound]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The optimizer used to rewrite (λx. M x) to M whenever x was not free
+in M. In a strict language this is not semantics-preserving: it moves
+the evaluation of M from every call of the lambda to the point where
+the lambda itself was constructed.
+
+That breaks self-referential instance dictionaries (issue #32). For
+
+  data Tree a = Leaf | Node { left ∷ Tree a, value ∷ a, right ∷ Tree a }
+  derive instance genericTree ∷ Generic (Tree a) _
+  instance eqTree ∷ Eq a ⇒ Eq (Tree a) where
+    eq x y = genericEq x y
+
+the method is deliberately eta-expanded by the user: the dictionary
+chain built by genericEq contains `eqTree dictEq` — a self-reference —
+and hiding it under λx λy is the documented PureScript way to break
+the cycle (upstream purs relies on it too: its JS output keeps the
+chain under the lambdas). Eta reduction rewrote the method to a bare
+application chain
+
+  eqTree = \dictEq → { eq = genericEq genericTree (… eqTree dictEq …) }
+
+which recurses at dictionary-construction time: calling `eqTree d`
+evaluates `eqTree d` eagerly and overflows the stack before any
+comparison happens. Golden/GenericEqTwoTypes is the regression test
+(two generic types, so the chain is multiply-used and the inliner
+cannot mask the problem by inlining it under another lambda).
+
+Reducing only special cases of M does not help either:
+
+  * M is an application — may diverge (the case above);
+  * M is a reference — a recursive-group member `f = λx. g x`
+    becomes the value binding `f = g`, but the laziness analysis
+    (CoreFn.Laziness.applyLazinessTransform) already ran on CoreFn
+    and never saw it, so nothing wraps it in runtime-lazy and `g`
+    may still be uninitialized when `f` is assigned;
+  * M is an abstraction — the redex (λy. K) x is already handled by
+    betaReduce, so nothing is left to gain.
+
+Hence no eta reduction is performed at all.
+-}
 
 betaReduceUnusedParams ∷ RewriteRule Ann
 betaReduceUnusedParams =

diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs
@@ -65,6 +65,17 @@ spec = describe "IR Optimizer" do
       let f = abstraction paramUnused body
       body === optimizedExpression (application f arg)
 
+    -- See Note [Eta reduction is unsound]
+    test "does not eta-reduce λx. M x to M" do
+      param ← forAll Gen.name
+      let dict = moduleNameFromString "Dict"
+          m =
+            application
+              (refImported dict (Name "eqList") 0)
+              (refImported dict (Name "eqInt") 0)
+          original = abstraction (paramNamed param) (application m (refLocal0 param))
+      optimizedExpression original === original
+
   describe "inlines expressions" do
     test "inlines literals" do
       name ← forAll Gen.name

diff --git a/test/ps/golden/Golden/BugListGenericEq/Test.purs b/test/ps/golden/Golden/BugListGenericEq/Test.purs
@@ -0,0 +1,23 @@
+module Golden.BugListGenericEq.Test where
+
+import Prelude
+import Data.Eq.Generic as GEq
+import Data.Generic.Rep as G
+import Effect (Effect)
+import Effect.Console (logShow)
+
+data List a = Nil | Cons { head :: a, tail :: List a }
+
+cons :: forall a. a -> List a -> List a
+cons head tail = Cons { head, tail }
+
+derive instance genericList :: G.Generic (List a) _
+
+instance eqList :: Eq a => Eq (List a) where
+  eq x y = GEq.genericEq x y
+
+main :: Effect Unit
+main = do
+  logShow $ (Nil :: List Int) == Nil
+  logShow $ cons 1 (cons 2 Nil) == cons 1 (cons 2 Nil)
+  logShow $ cons 1 Nil == cons 2 Nil
diff --git a/test/ps/golden/Golden/DerivedFunctor/Test.purs b/test/ps/golden/Golden/DerivedFunctor/Test.purs
@@ -0,0 +1,30 @@
+module Golden.DerivedFunctor.Test where
+
+import Prelude
+import Effect (Effect)
+import Effect.Console (logShow)
+
+data Either a b = Left a | Right b
+
+derive instance functorEither :: Functor (Either a)
+
+data Tree a = Leaf | Node (Tree a) a (Tree a)
+
+derive instance functorTree :: Functor Tree
+
+fromRight :: forall a. Int -> Either a Int -> Int
+fromRight fallback = case _ of
+  Left _ -> fallback
+  Right n -> n
+
+sumTree :: Tree Int -> Int
+sumTree = case _ of
+  Leaf -> 0
+  Node l x r -> sumTree l + x + sumTree r
+
+main :: Effect Unit
+main = do
+  logShow $ fromRight 0 $ map (_ + 1) (Right 41 :: Either String Int)
+  logShow $ fromRight 7 $ map (_ + 1) (Left "no" :: Either String Int)
+  logShow $ sumTree $ map (_ * 2)
+    $ Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 Leaf)
diff --git a/test/ps/golden/Golden/GenericEqTwoTypes/Test.purs b/test/ps/golden/Golden/GenericEqTwoTypes/Test.purs
@@ -0,0 +1,34 @@
+module Golden.GenericEqTwoTypes.Test where
+
+import Prelude
+import Data.Eq.Generic as GEq
+import Data.Generic.Rep as G
+import Effect (Effect)
+import Effect.Console (logShow)
+
+data List a = Nil | Cons { head :: a, tail :: List a }
+
+cons :: forall a. a -> List a -> List a
+cons head tail = Cons { head, tail }
+
+derive instance genericList :: G.Generic (List a) _
+
+instance eqList :: Eq a => Eq (List a) where
+  eq x y = GEq.genericEq x y
+
+data Tree a = Leaf | Node { left :: Tree a, value :: a, right :: Tree a }
+
+node :: forall a. Tree a -> a -> Tree a -> Tree a
+node left value right = Node { left, value, right }
+
+derive instance genericTree :: G.Generic (Tree a) _
+
+instance eqTree :: Eq a => Eq (Tree a) where
+  eq x y = GEq.genericEq x y
+
+main :: Effect Unit
+main = do
+  logShow $ cons 1 (cons 2 Nil) == cons 1 (cons 2 Nil)
+  logShow $ cons 1 Nil == cons 2 Nil
+  logShow $ node Leaf 1 (node Leaf 2 Leaf) == node Leaf 1 (node Leaf 2 Leaf)
+  logShow $ node Leaf 1 Leaf == node Leaf 2 Leaf