Fix #12709 by not building bad applications

In an effort to report multiple levity polymorphism errors all at
once, the desugarer does not fail when encountering bad levity
polymorphism. But we must be careful not to build the bad applications,
lest they try to satisfy the let/app invariant and call
isUnliftedType on a levity polymorphic type. This protects calls
to mkCoreAppDs appropriately.

test case: typecheck/should_fail/T12709

8 files changed, 96 insertions, 15 deletions

diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 7ba9445f7c..5a29994d0e 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -21,7 +21,7 @@ module MkCore (
 
         -- * Constructing small tuples
         mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
-        mkCoreTupBoxity,
+        mkCoreTupBoxity, unitExpr,
 
         -- * Constructing big tuples
         mkBigCoreVarTup, mkBigCoreVarTup1,
@@ -396,6 +396,9 @@ mkBigCoreTup = mkChunkified mkCoreTup
 mkBigCoreTupTy :: [Type] -> Type
 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
 
+-- | The unit expression
+unitExpr :: CoreExpr
+unitExpr = Var unitDataConId
 
 {-
 ************************************************************************
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 42a28c962a..e31f23fffa 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1135,8 +1135,10 @@ dsHsWrapper (WpFun c1 c2 t1 doc)
                                    ; w2 <- dsHsWrapper c2
                                    ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
                                          arg     = w1 (Var x)
-                                   ; dsNoLevPolyExpr arg doc
-                                   ; return (\e -> (Lam x (w2 (app e arg)))) }
+                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
+                                   ; if ok
+                                     then return (\e -> (Lam x (w2 (app e arg))))
+                                     else return id }  -- this return is irrelevant
 dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)
                                 return $ \e -> mkCastDs e co
 dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index faf562e428..39f76ea2c0 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -292,7 +292,9 @@ dsExpr (HsLamCase matches)
        ; return $ Lam discrim_var matching_code }
 
 dsExpr e@(HsApp fun arg)
-  = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExprNoLP arg
+  = do { fun' <- dsLExpr fun
+       ; dsWhenNoErrs (dsLExprNoLP arg)
+                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
 
 dsExpr (HsAppTypeOut e _)
     -- ignore type arguments here; they're in the wrappers instead at this point
@@ -340,10 +342,14 @@ will sort it out.
 
 dsExpr e@(OpApp e1 op _ e2)
   = -- for the type of y, we need the type of op's 2nd argument
-    mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExprNoLP [e1, e2]
+    do { op' <- dsLExpr op
+       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
+                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
 
 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
-  = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExprNoLP expr
+  = do { op' <- dsLExpr op
+       ; dsWhenNoErrs (dsLExprNoLP expr)
+                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
 
 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 dsExpr e@(SectionR op expr) = do
@@ -352,10 +358,10 @@ dsExpr e@(SectionR op expr) = do
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
         -- See comment with SectionL
     y_core <- dsLExpr expr
-    x_id <- newSysLocalDsNoLP x_ty
-    y_id <- newSysLocalDsNoLP y_ty
-    return (bindNonRec y_id y_core $
-            Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
+    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
+                 (\[x_id, y_id] -> bindNonRec y_id y_core $
+                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
+                                                          core_op [Var x_id, Var y_id]))
 
 dsExpr (ExplicitTuple tup_args boxity)
   = do { let go (lam_vars, args) (L _ (Missing ty))
@@ -765,8 +771,8 @@ dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
        ; core_res_wrap  <- dsHsWrapper res_wrap
        ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
-       ; zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]
-       ; return (core_res_wrap (mkApps fun wrapped_args)) }
+       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
+                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
   where
     mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
 
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 940b8a276b..fdca76c5b8 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -49,13 +49,13 @@ module DsMonad (
         CanItFail(..), orFail,
 
         -- Levity polymorphism
-        dsNoLevPoly, dsNoLevPolyExpr
+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs
     ) where
 
 import TcRnMonad
 import FamInstEnv
 import CoreSyn
-import MkCore    ( mkCoreTup )
+import MkCore    ( unitExpr )
 import CoreUtils ( exprType, isExprLevPoly )
 import HsSyn
 import TcIface
@@ -444,7 +444,7 @@ errDs err
 errDsCoreExpr :: SDoc -> DsM CoreExpr
 errDsCoreExpr err
   = do { errDs err
-       ; return $ mkCoreTup [] }
+       ; return unitExpr }
 
 failWithDs :: SDoc -> DsM a
 failWithDs err
@@ -570,6 +570,20 @@ dsNoLevPolyExpr e doc
   | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
   | 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 levity polymorphism checks and then avoiding making a core App.
+-- (If we make a core App on a levity polymorphic argument, detecting how
+-- to handle the let/app invariant might call isUnliftedType, which panics
+-- on a levity 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 }
+
 --------------------------------------------------------------------------
 --                  Data Parallel Haskell
 --------------------------------------------------------------------------
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 165130aa94..db757d6afe 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -540,6 +540,7 @@ into
 which stupidly tries to bind the datacon 'True'.
 -}
 
+-- NB: Make sure the argument is not levity polymorphic
 mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
 mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
   | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
@@ -552,6 +553,7 @@ mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
 
 mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
 
+-- NB: No argument can be levity polymorphic
 mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
 mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
 
diff --git a/testsuite/tests/typecheck/should_fail/T12709.hs b/testsuite/tests/typecheck/should_fail/T12709.hs
new file mode 100644
index 0000000000..2bbcf744d0
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12709.hs
@@ -0,0 +1,29 @@
+{-# Language MagicHash, PolyKinds, ViewPatterns, TypeInType, RebindableSyntax, NoImplicitPrelude #-}
+
+module T12709 where
+
+import GHC.Types
+import Prelude hiding (Num (..))
+import qualified Prelude as P
+import GHC.Prim
+
+data BoxUnbox = BUB Int Int#
+
+class Num (a :: TYPE rep) where
+  (+) :: a -> a -> a
+
+  fromInteger :: Integer -> a
+
+instance Num Int where
+  (+) = (P.+)
+  fromInteger = P.fromInteger
+
+instance Num Int# where
+  (+) = (+#)
+  fromInteger (fromInteger -> I# n) = n
+
+a :: BoxUnbox
+a = let u :: Num (a :: TYPE rep) => a
+        u = 1 + 2 + 3 + 4
+     in
+        BUB u u
diff --git a/testsuite/tests/typecheck/should_fail/T12709.stderr b/testsuite/tests/typecheck/should_fail/T12709.stderr
new file mode 100644
index 0000000000..7be861c061
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12709.stderr
@@ -0,0 +1,24 @@
+
+T12709.hs:27:13: error:
+    A levity-polymorphic type is not allowed here:
+      Type: a
+      Kind: TYPE rep
+    In the type of expression: 1
+
+T12709.hs:27:17: error:
+    A levity-polymorphic type is not allowed here:
+      Type: a
+      Kind: TYPE rep
+    In the type of expression: 2
+
+T12709.hs:27:21: error:
+    A levity-polymorphic type is not allowed here:
+      Type: a
+      Kind: TYPE rep
+    In the type of expression: 3
+
+T12709.hs:27:25: error:
+    A levity-polymorphic type is not allowed here:
+      Type: a
+      Kind: TYPE rep
+    In the type of expression: 4
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 2d1d12bf74..13ea1d7a41 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -429,3 +429,4 @@ test('T13105', normal, compile_fail, [''])
 test('LevPolyBounded', normal, compile_fail, [''])
 test('T13292', normal, multimod_compile, ['T13292', '-v0 -fdefer-type-errors'])
 test('T13300', normal, compile_fail, [''])
+test('T12709', normal, compile_fail, [''])