Don't return unitExpr in dsWhenNoErrs

  - fixes #18149 and #14765

dsWhenNoErrs now returns "runtimeError @ty" when disallowed
representation polymorphism is detected, where ty is the type of the
result CoreExpr. "ty" is passed as an additional argument to
dsWhenNoErrs, and is used only in the case of such an error.

The calls to dsWhenNoErrs must now compute the type of the
CoreExpr they are trying to build, so that an error of the right type
can be used in case of a representation polymorphism failure.

8 files changed, 124 insertions, 26 deletions

diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 1c9b1706bd..58af03f481 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -5,7 +5,7 @@
 -- this task, see #12706, #15320, #16804, and #17331.
 module GHC.Hs.Syn.Type (
     -- * Extracting types from HsExpr
-    lhsExprType, hsExprType,
+    lhsExprType, hsExprType, hsWrapperType,
     -- * Extracting types from HsSyn
     hsLitType, hsPatType, hsLPatType
 
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index b98f5c86f9..e06634fb3f 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -30,6 +30,7 @@ import GHC.HsToCore.Arrows
 import GHC.HsToCore.Monad
 import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
 import GHC.HsToCore.Errors.Types
+import GHC.Hs.Syn.Type ( hsExprType, hsWrapperType )
 import GHC.Types.SourceText
 import GHC.Types.Name
 import GHC.Types.Name.Env
@@ -302,7 +303,9 @@ dsExpr (HsLamCase _ matches)
 
 dsExpr e@(HsApp _ fun arg)
   = do { fun' <- dsLExpr fun
-       ; dsWhenNoErrs (dsLExprNoLP arg)
+       -- See Note [Desugaring representation-polymorphic applications]
+       --   in GHC.HsToCore.Utils
+       ; dsWhenNoErrs (hsExprType e) (dsLExprNoLP arg)
                       (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
 
 dsExpr e@(HsAppType {}) = dsHsWrapped e
@@ -325,7 +328,7 @@ That 'g' in the 'in' part is an evidence variable, and when
 converting to core it must become a CO.
 -}
 
-dsExpr (ExplicitTuple _ tup_args boxity)
+dsExpr e@(ExplicitTuple _ tup_args boxity)
   = do { let go (lam_vars, args) (Missing (Scaled mult ty))
                     -- For every missing expression, we need
                     -- another lambda in the desugaring.
@@ -337,15 +340,20 @@ dsExpr (ExplicitTuple _ tup_args boxity)
                = do { core_expr <- dsLExprNoLP expr
                     ; return (lam_vars, core_expr : args) }
 
-       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
+       -- See Note [Desugaring representation-polymorphic applications]
+       --   in GHC.HsToCore.Utils
+       ; dsWhenNoErrs (hsExprType e) (foldM go ([], []) (reverse tup_args))
                 -- The reverse is because foldM goes left-to-right
                       (\(lam_vars, args) ->
                         mkCoreLams lam_vars $
                           mkCoreTupBoxity boxity args) }
                         -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
 
-dsExpr (ExplicitSum types alt arity expr)
-  = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types)
+dsExpr e@(ExplicitSum types alt arity expr)
+  -- See Note [Desugaring representation-polymorphic applications]
+  --   in GHC.HsToCore.Utils
+  = dsWhenNoErrs (hsExprType e) (dsLExprNoLP expr)
+      (mkCoreUbxSum arity alt types)
 
 dsExpr (HsPragE _ prag expr) =
   ds_prag_expr prag expr
@@ -796,10 +804,21 @@ dsSyntaxExpr (SyntaxExprTc { syn_expr      = expr
        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
        ; core_res_wrap  <- dsHsWrapper res_wrap
        ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs
-       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ])
-                      (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) }
-                      -- Use mkCoreApps instead of mkApps:
-                      -- unboxed types are possible with RebindableSyntax (#19883)
+        -- We need to compute the type of the desugared expression without
+        -- actually performing the desugaring, which could be problematic
+        -- in the presence of representation polymorphism.
+        -- See Note [Desugaring representation-polymorphic applications]
+        --   in GHC.HsToCore.Utils
+             expr_type = hsWrapperType res_wrap
+               (applyTypeToArgs fun (exprType fun) wrapped_args)
+       ; dsWhenNoErrs expr_type
+          (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ])
+          (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) }
+             -- Use mkCoreApps instead of mkApps:
+             -- unboxed types are possible with RebindableSyntax (#19883)
+             -- This won't be evaluated if there are any
+             -- representation-polymorphic arguments.
+
   where
     mk_msg n = LevityCheckInSyntaxExpr (DsArgNum n) expr
 dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index d1689ce81a..6fd3ef10c4 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -49,7 +49,7 @@ module GHC.HsToCore.Monad (
         EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
 
         -- Representation polymorphism
-        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
+        dsNoLevPoly, dsNoLevPolyExpr,
 
         -- Trace injection
         pprRuntimeTrace
@@ -610,20 +610,6 @@ dsNoLevPolyExpr e provenance
   | isExprLevPoly e = diagnosticDs (DsLevityPolyInExpr e provenance)
   | otherwise       = return ()
 
--- | Runs the thing_inside. If there are no errors, then returns the expr
--- given. Otherwise, returns unitExpr. This is useful for doing a bunch
--- of representation polymorphism checks and then avoiding making a core App.
--- (If we make a core App on a representation-polymorphic argument, detecting
--- how to handle the let/app invariant might call isUnliftedType, which panics
--- on a representation-polymorphic type.)
--- See #12709 for an example of why this machinery is necessary.
-dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
-dsWhenNoErrs thing_inside mk_expr
-  = do { (result, no_errs) <- askNoErrsDs thing_inside
-       ; return $ if no_errs
-                  then mk_expr result
-                  else unitExpr }
-
 -- | Inject a trace message into the compiled program. Whereas
 -- pprTrace prints out information *while compiling*, pprRuntimeTrace
 -- captures that information and causes it to be printed *at runtime*
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 5c68525f12..333929c956 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -30,7 +30,7 @@ module GHC.HsToCore.Utils (
         wrapBind, wrapBinds,
 
         mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
-        mkFailExpr,
+        mkFailExpr, dsWhenNoErrs,
 
         seqVar,
 
@@ -982,6 +982,69 @@ mk_fail_msg dflags ctx pat
   = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx
                    <+> text "at" <+> ppr (getLocA pat)
 
+{- Note [Desugaring representation-polymorphic applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To desugar a function application
+
+> HsApp _ f e :: HsExpr GhcTc
+
+into Core, we need to know whether the argument e is lifted or unlifted,
+in order to respect the let/app invariant.
+  (See Note [Core let/app invariant] in GHC.Core)
+
+This causes a problem when e is representation-polymorphic, as we aren't able
+to determine whether to build a Core application
+
+> f_desugared e_desugared
+
+or a strict binding:
+
+> case e_desugared of { x -> f_desugared x }
+
+See GHC.Core.Make.mkValApp, which will call isUnliftedType, which panics
+on a representation-polymorphic type.
+
+These representation-polymorphic applications are disallowed in source Haskell,
+but we might want to continue desugaring as much as possible instead of
+aborting as soon as we see such a problematic function application.
+
+When desugaring an expression which might have problems (such as disallowed
+representation polymorphism as above), we check for errors first, and then:
+
+  - if no problems were detected, desugar normally,
+  - if errors were found, we want to avoid desugaring, so we instead return
+    a runtime error Core expression which has the right type.
+
+This is what the function dsWhenNoErrs achieves:
+
+> dsWhenNoErrs result_ty thing_inside mk_expr
+
+We run thing_inside to check for errors. If there are no errors, we apply
+mk_expr to desugar; otherwise, we construct a runtime error at type result_ty.
+
+Note that result_ty is only used when there is an error, and isn't inspected
+otherwise; this means it's OK to pass something that can be a bit expensive
+to compute.
+
+See #12709 for an example of why this machinery is necessary.
+See also #14765 and #18149 for why it is important to return an expression
+that has the proper type in case of an error.
+-}
+
+-- | Runs the thing_inside. If there are no errors, use the provided
+-- function to construct a Core expression, and return it.
+-- Otherwise, return a runtime error, of the given type.
+-- This is useful for doing a bunch of representation polymorphism checks
+-- and then avoiding making a Core App.
+-- See Note [Desugaring representation-polymorphic applications]
+dsWhenNoErrs :: Type -> DsM a -> (a -> CoreExpr) -> DsM CoreExpr
+dsWhenNoErrs result_ty thing_inside mk_expr
+  = do { (result, no_errs) <- askNoErrsDs thing_inside
+       ; if no_errs
+         then return $ mk_expr result
+         else mkErrorAppDs rUNTIME_ERROR_ID result_ty
+            (text "dsWhenNoErrs found errors") }
+
 {- *********************************************************************
 *                                                                      *
               Ticks
diff --git a/testsuite/tests/typecheck/should_fail/T12709.stderr b/testsuite/tests/typecheck/should_fail/T12709.stderr
index f8da5ea120..1d3334c6f7 100644
--- a/testsuite/tests/typecheck/should_fail/T12709.stderr
+++ b/testsuite/tests/typecheck/should_fail/T12709.stderr
@@ -5,6 +5,18 @@ T12709.hs:28:13: error:
       Kind: TYPE rep
     In the type of expression: 1
 
+T12709.hs:28:13: error:
+    A representation-polymorphic type is not allowed here:
+      Type: a
+      Kind: TYPE rep
+    In the type of expression: 1 + 2
+
+T12709.hs:28:13: error:
+    A representation-polymorphic type is not allowed here:
+      Type: a
+      Kind: TYPE rep
+    In the type of expression: 1 + 2 + 3
+
 T12709.hs:28:17: error:
     A representation-polymorphic type is not allowed here:
       Type: a
diff --git a/testsuite/tests/typecheck/should_fail/T14765.hs b/testsuite/tests/typecheck/should_fail/T14765.hs
new file mode 100644
index 0000000000..b124252bb4
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14765.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE MagicHash, PolyKinds, ExplicitForAll #-}
+
+module T14765 where
+
+import GHC.Exts
+
+fold :: forall rep a (r :: TYPE rep).
+          (r -> a -> Proxy# r -> r) -> (Proxy# r -> r) -> [a] -> r
+fold f k [] = k proxy#
+fold f k (x : xs) = fold f (f (k proxy#) x) xs
diff --git a/testsuite/tests/typecheck/should_fail/T14765.stderr b/testsuite/tests/typecheck/should_fail/T14765.stderr
new file mode 100644
index 0000000000..c837c0d717
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14765.stderr
@@ -0,0 +1,6 @@
+
+T14765.hs:11:31: error:
+    A representation-polymorphic type is not allowed here:
+      Type: r
+      Kind: TYPE rep
+    In the type of expression: (k proxy#)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index b776f1d5dd..8745ea9172 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -480,6 +480,7 @@ test('T14607', normal, compile_fail, [''])
 test('T14605', normal, compile_fail, [''])
 test('T14761a', normal, compile_fail, [''])
 test('T14761b', normal, compile_fail, [''])
+test('T14765', normal, compile_fail, [''])
 test('T14884', normal, compile_fail, [''])
 test('T14904a', normal, compile_fail, [''])
 test('T14904b', normal, compile_fail, [''])