HsToCore: Eta expand left sectionswip/T18151

Strangely, the comment next to this code already alluded to the fact
that even simply eta-expanding will sacrifice laziness. It's quite
unclear how we regressed so far.

See #18151.

2 files changed, 65 insertions, 26 deletions

diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 5739b26319..fb3424c2f9 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -338,26 +338,47 @@ Then we get
 That 'g' in the 'in' part is an evidence variable, and when
 converting to core it must become a CO.
 
-Operator sections.  At first it looks as if we can convert
-\begin{verbatim}
-        (expr op)
-\end{verbatim}
-to
-\begin{verbatim}
-        \x -> op expr x
-\end{verbatim}
+
+Note [Desugaring operator sections]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At first it looks as if we can convert
+
+    (expr `op`)
+
+naively to
+
+    \x -> op expr x
 
 But no!  expr might be a redex, and we can lose laziness badly this
 way.  Consider
-\begin{verbatim}
-        map (expr op) xs
-\end{verbatim}
-for example.  So we convert instead to
-\begin{verbatim}
-        let y = expr in \x -> op y x
-\end{verbatim}
-If \tr{expr} is actually just a variable, say, then the simplifier
-will sort it out.
+
+    map (expr `op`) xs
+
+for example. If expr were a redex then eta-expanding naively would
+result in multiple evaluations where the user might only have expected one.
+
+So we convert instead to
+
+    let y = expr in \x -> op y x
+
+Also, note that we must do this for both right and (perhaps surprisingly) left
+sections. Why are left sections necessary? Consider the program (found in #18151),
+
+    seq (True `undefined`) ()
+
+according to the Haskell Report this should reduce to () (as it specifies
+desugaring via eta expansion). However, if we fail to eta expand we will rather
+bottom. Consequently, we must eta expand even in the case of a left section.
+
+If `expr` is actually just a variable, say, then the simplifier
+will inline `y`, eliminating the redundant `let`.
+
+Note that this works even in the case that `expr` is unlifted. In this case
+bindNonRec will automatically do the right thing, giving us:
+
+    case expr of y -> (\x -> op y x)
+
+See #18151.
 -}
 
 dsExpr e@(OpApp _ e1 op e2)
@@ -366,17 +387,35 @@ dsExpr e@(OpApp _ e1 op e2)
        ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
                       (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
 
-dsExpr (SectionL _ expr op)       -- Desugar (e !) to ((!) e)
-  = do { op' <- dsLExpr op
-       ; dsWhenNoErrs (dsLExprNoLP expr)
-                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
-
--- dsLExpr (SectionR op expr)   -- \ x -> op x expr
+-- dsExpr (SectionL op expr)  ===  (expr `op`)  ~>  \y -> op expr y
+--
+-- See Note [Desugaring operator sections].
+-- N.B. this also must handle postfix operator sections due to -XPostfixOperators.
+dsExpr e@(SectionL _ expr op) = do
+    core_op <- dsLExpr op
+    x_core <- dsLExpr expr
+    case splitFunTys (exprType core_op) of
+      -- Binary operator section
+      (x_ty:y_ty:_, _) -> do
+        dsWhenNoErrs
+          (mapM newSysLocalDsNoLP [x_ty, y_ty])
+          (\[x_id, y_id] ->
+            bindNonRec x_id x_core
+            $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)
+                                     core_op [Var x_id, Var y_id]))
+
+      -- Postfix operator section
+      (_:_, _) -> do
+        return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core
+
+      _ -> pprPanic "dsExpr(SectionL)" (ppr e)
+
+-- dsExpr (SectionR op expr)  === (`op` expr)  ~>  \x -> op x expr
+--
+-- See Note [Desugaring operator sections].
 dsExpr e@(SectionR _ op expr) = do
     core_op <- dsLExpr op
-    -- for the type of x, we need the type of op's 2nd argument
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
-        -- See comment with SectionL
     y_core <- dsLExpr expr
     dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
                  (\[x_id, y_id] -> bindNonRec y_id y_core $
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 8d53568be9..214f088aea 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -64,4 +64,4 @@ test('T11601', exit_code(1), compile_and_run, [''])
 test('T11747', normal, compile_and_run, ['-dcore-lint'])
 test('T12595', normal, compile_and_run, [''])
 test('T13285', normal, compile_and_run, [''])
-test('T18151', expect_broken(18151), compile_and_run, [''])
+test('T18151', normal, compile_and_run, [''])