Allow visible type application for levity-poly data conswip/T18481

This patch was driven by #18481, to allow visible type application
for levity-polymorphic newtypes. As so often, it started simple
but grew:

* Significant refactor: I removed HsConLikeOut from the
  client-independent Language.Haskell.Syntax.Expr, and put it where it
  belongs, as a new constructor `ConLikeTc` in the GHC-specific extension
  data type for expressions, `GHC.Hs.Expr.XXExprGhcTc`.

  That changed touched a lot of files in a very superficial way.

* Note [Typechecking data constructors] explains the main payload.
  The eta-expansion part is no longer done by the typechecker, but
  instead deferred to the desugarer, via `ConLikeTc`

* A little side benefit is that I was able to restore VTA for
  data types with a "stupid theta": #19775.  Not very important,
  but the code in GHC.Tc.Gen.Head.tcInferDataCon is is much, much
  more elegant now.

* I had to refactor the levity-polymorphism checking code in
  GHC.HsToCore.Expr, see
     Note [Checking for levity-polymorphic functions]
     Note [Checking levity-polymorphic data constructors]

1 files changed, 25 insertions, 11 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index b3ed2ce8eb..7eaec265a8 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -490,7 +490,18 @@ lintCoreBindings dflags pass local_in_scope binds
                { lf_check_global_ids = check_globals
                , lf_check_inline_loop_breakers = check_lbs
                , lf_check_static_ptrs = check_static_ptrs
-               , lf_check_linearity = check_linearity }
+               , lf_check_linearity = check_linearity
+               , lf_check_levity_poly = check_levity }
+
+    -- In the output of the desugarer, before optimisation,
+    -- we have eta-expanded data constructors with levity-polymorphic
+    -- bindings; so we switch off the lev-poly checks. The very simple
+    -- optimiser will beta-reduce them away.
+    -- See Note [Checking levity-polymorphic data constructors]
+    -- in GHC.HsToCore.Expr.
+    check_levity = case pass of
+                      CoreDesugar -> False
+                      _           -> True
 
     -- See Note [Checking for global Ids]
     check_globals = case pass of
@@ -541,7 +552,6 @@ lintCoreBindings dflags pass local_in_scope binds
 
 Note [Linting Unfoldings from Interfaces]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 We use this to check all top-level unfoldings that come in from interfaces
 (it is very painful to catch errors otherwise).
 
@@ -922,9 +932,9 @@ lintCoreExpr e@(App _ _)
   , fun `hasKey` runRWKey
     -- N.B. we may have an over-saturated application of the form:
     --   runRW (\s -> \x -> ...) y
-  , arg_ty1 : arg_ty2 : arg3 : rest <- args
-  = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) arg_ty1
-       ; (fun_ty2, ue2) <- lintCoreArg fun_pair1      arg_ty2
+  , ty_arg1 : ty_arg2 : arg3 : rest <- args
+  = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1
+       ; (fun_ty2, ue2) <- lintCoreArg fun_pair1       ty_arg2
          -- See Note [Linting of runRW#]
        ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)
              lintRunRWCont expr@(Lam _ _) =
@@ -1190,13 +1200,17 @@ lintCoreArg (fun_ty, fun_ue) arg
   = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg
            -- See Note [Levity polymorphism invariants] in GHC.Core
        ; flags <- getLintFlags
-       ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty))
-           (text "Levity-polymorphic argument:" <+>
-             (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))
-          -- check for levity polymorphism first, because otherwise isUnliftedType panics
 
-       ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
-                (mkLetAppMsg arg)
+       ; when (lf_check_levity_poly flags) $
+         -- Only do these checks if lf_check_levity_poly is on,
+         -- because otherwise isUnliftedType panics
+         do { checkL (not (isTypeLevPoly arg_ty))
+                     (text "Levity-polymorphic argument:"
+                      <+> ppr arg <+> dcolon
+                      <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))
+
+            ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
+                     (mkLetAppMsg arg) }
 
        ; lintValApp arg fun_ty arg_ty fun_ue arg_ue }