Allow visible type application for levity-poly data cons

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, 124 insertions, 78 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index fb523bb74a..f812c66540 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -52,6 +52,7 @@ import GHC.Types.Basic
 import GHC.Types.Fixity
 import GHC.Types.SourceText
 import GHC.Types.SrcLoc
+import GHC.Types.Var( InvisTVBinder )
 import GHC.Core.ConLike
 import GHC.Unit.Module (ModuleName)
 import GHC.Utils.Misc
@@ -218,7 +219,6 @@ data EpAnnUnboundVar = EpAnnUnboundVar
      } deriving Data
 
 type instance XVar           (GhcPass _) = NoExtField
-type instance XConLikeOut    (GhcPass _) = NoExtField
 type instance XRecFld        (GhcPass _) = NoExtField
 type instance XLam           (GhcPass _) = NoExtField
 
@@ -240,7 +240,6 @@ type instance XUnboundVar    GhcTc = HoleExprRef
   -- Much, much easier just to define HoleExprRef with a Data instance and
   -- store the whole structure.
 
-type instance XConLikeOut    (GhcPass _) = NoExtField
 type instance XRecFld        (GhcPass _) = NoExtField
 type instance XIPVar         (GhcPass _) = EpAnnCO
 type instance XOverLitE      (GhcPass _) = EpAnnCO
@@ -361,21 +360,9 @@ type instance XBinTick       (GhcPass _) = NoExtField
 
 type instance XPragE         (GhcPass _) = NoExtField
 
-type instance XXExpr         GhcPs       = NoExtCon
-
--- See Note [Rebindable syntax and HsExpansion] below
-type instance XXExpr         GhcRn       = HsExpansion (HsExpr GhcRn)
-                                                       (HsExpr GhcRn)
-type instance XXExpr         GhcTc       = XXExprGhcTc
-
-
 type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL
 type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA
 
-data XXExprGhcTc
-  = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)
-  | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
-
 data AnnExplicitSum
   = AnnExplicitSum {
       aesOpen       :: EpaLocation,
@@ -421,6 +408,40 @@ tupArgPresent :: HsTupArg (GhcPass p) -> Bool
 tupArgPresent (Present {}) = True
 tupArgPresent (Missing {}) = False
 
+
+{- *********************************************************************
+*                                                                      *
+            XXExpr: the extension constructor of HsExpr
+*                                                                      *
+********************************************************************* -}
+
+type instance XXExpr GhcPs = NoExtCon
+type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)
+type instance XXExpr GhcTc = XXExprGhcTc
+-- HsExpansion: see Note [Rebindable syntax and HsExpansion] below
+
+
+data XXExprGhcTc
+  = WrapExpr        -- Type and evidence application and abstractions
+      {-# UNPACK #-} !(HsWrap HsExpr)
+
+  | ExpansionExpr   -- See Note [Rebindable syntax and HsExpansion] below
+      {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
+
+  | ConLikeTc      -- Result of typechecking a data-con
+                   -- See Note [Typechecking data constructors] in
+                   --     GHC.Tc.Gen.Head
+                   -- The two arguments describe how to eta-expand
+                   -- the data constructor when desugaring
+        ConLike [InvisTVBinder] [Scaled TcType]
+
+
+{- *********************************************************************
+*                                                                      *
+            Pretty-printing expressions
+*                                                                      *
+********************************************************************* -}
+
 instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where
     ppr expr = pprExpr expr
 
@@ -457,7 +478,6 @@ ppr_expr :: forall p. (OutputableBndrId p)
          => HsExpr (GhcPass p) -> SDoc
 ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v
 ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv
-ppr_expr (HsConLikeOut _ c)  = pprPrefixOcc c
 ppr_expr (HsRecFld _ f)      = pprPrefixOcc f
 ppr_expr (HsIPVar _ v)       = ppr v
 ppr_expr (HsOverLabel _ l)   = char '#' <> ppr l
@@ -638,27 +658,41 @@ ppr_expr (XExpr x) = case ghcPass @p of
   GhcPs -> ppr x
 #endif
   GhcRn -> ppr x
-  GhcTc -> case x of
-    WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn
-      (\parens -> if parens then pprExpr e else pprExpr e)
-    ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original
-                             -- expression (LHsExpr GhcPs), not the
-                             -- desugared one (LHsExpr GhcT).
+  GhcTc -> ppr x
+
+instance Outputable XXExprGhcTc where
+  ppr (WrapExpr (HsWrap co_fn e))
+    = pprHsWrapper co_fn (\_parens -> pprExpr e)
+
+  ppr (ExpansionExpr e)
+    = ppr e -- e is an HsExpansion, we print the original
+            -- expression (LHsExpr GhcPs), not the
+            -- desugared one (LHsExpr GhcTc).
+
+  ppr (ConLikeTc con _ _) = pprPrefixOcc con
+   -- Used in error messages generated by
+   -- the pattern match overlap checker
 
 ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
 ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)
-ppr_infix_expr (HsConLikeOut _ c)   = Just (pprInfixOcc (conLikeName c))
 ppr_infix_expr (HsRecFld _ f)       = Just (pprInfixOcc f)
 ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
-ppr_infix_expr (XExpr x)            = case (ghcPass @p, x) of
+ppr_infix_expr (XExpr x)            = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 901
-  (GhcPs, _)                              -> Nothing
+                                        GhcPs -> Nothing
 #endif
-  (GhcRn, HsExpanded a _)                 -> ppr_infix_expr a
-  (GhcTc, WrapExpr (HsWrap _ e))          -> ppr_infix_expr e
-  (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a
+                                        GhcRn -> ppr_infix_expr_rn x
+                                        GhcTc -> ppr_infix_expr_tc x
 ppr_infix_expr _ = Nothing
 
+ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc
+ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a
+
+ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
+ppr_infix_expr_tc (WrapExpr (HsWrap _ e))          = ppr_infix_expr e
+ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a
+ppr_infix_expr_tc (ConLikeTc {})                   = Nothing
+
 ppr_apps :: (OutputableBndrId p)
          => HsExpr (GhcPass p)
          -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
@@ -698,67 +732,70 @@ pprParendExpr p expr
 -- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs
 -- parentheses under precedence @p@.
 hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool
-hsExprNeedsParens p = go
+hsExprNeedsParens prec = go
   where
+    go :: HsExpr (GhcPass p) -> Bool
     go (HsVar{})                      = False
     go (HsUnboundVar{})               = False
-    go (HsConLikeOut{})               = False
     go (HsIPVar{})                    = False
     go (HsOverLabel{})                = False
-    go (HsLit _ l)                    = hsLitNeedsParens p l
-    go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol
+    go (HsLit _ l)                    = hsLitNeedsParens prec l
+    go (HsOverLit _ ol)               = hsOverLitNeedsParens prec ol
     go (HsPar{})                      = False
-    go (HsApp{})                      = p >= appPrec
-    go (HsAppType {})                 = p >= appPrec
-    go (OpApp{})                      = p >= opPrec
-    go (NegApp{})                     = p > topPrec
+    go (HsApp{})                      = prec >= appPrec
+    go (HsAppType {})                 = prec >= appPrec
+    go (OpApp{})                      = prec >= opPrec
+    go (NegApp{})                     = prec > topPrec
     go (SectionL{})                   = True
     go (SectionR{})                   = True
     -- Special-case unary boxed tuple applications so that they are
     -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
     -- See Note [One-tuples] in GHC.Builtin.Types
     go (ExplicitTuple _ [Present{}] Boxed)
-                                      = p >= appPrec
+                                      = prec >= appPrec
     go (ExplicitTuple{})              = False
     go (ExplicitSum{})                = False
-    go (HsLam{})                      = p > topPrec
-    go (HsLamCase{})                  = p > topPrec
-    go (HsCase{})                     = p > topPrec
-    go (HsIf{})                       = p > topPrec
-    go (HsMultiIf{})                  = p > topPrec
-    go (HsLet{})                      = p > topPrec
+    go (HsLam{})                      = prec > topPrec
+    go (HsLamCase{})                  = prec > topPrec
+    go (HsCase{})                     = prec > topPrec
+    go (HsIf{})                       = prec > topPrec
+    go (HsMultiIf{})                  = prec > topPrec
+    go (HsLet{})                      = prec > topPrec
     go (HsDo _ sc _)
       | isComprehensionContext sc     = False
-      | otherwise                     = p > topPrec
+      | otherwise                     = prec > topPrec
     go (ExplicitList{})               = False
     go (RecordUpd{})                  = False
-    go (ExprWithTySig{})              = p >= sigPrec
+    go (ExprWithTySig{})              = prec >= sigPrec
     go (ArithSeq{})                   = False
-    go (HsPragE{})                    = p >= appPrec
+    go (HsPragE{})                    = prec >= appPrec
     go (HsSpliceE{})                  = False
     go (HsBracket{})                  = False
     go (HsRnBracketOut{})             = False
     go (HsTcBracketOut{})             = False
-    go (HsProc{})                     = p > topPrec
-    go (HsStatic{})                   = p >= appPrec
+    go (HsProc{})                     = prec > topPrec
+    go (HsStatic{})                   = prec >= appPrec
     go (HsTick _ _ (L _ e))           = go e
     go (HsBinTick _ _ _ (L _ e))      = go e
     go (RecordCon{})                  = False
     go (HsRecFld{})                   = False
     go (HsProjection{})               = True
     go (HsGetField{})                 = False
-    go (XExpr x)
-      | GhcTc <- ghcPass @p
-      = case x of
-          WrapExpr      (HsWrap _ e)     -> go e
-          ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a
-      | GhcRn <- ghcPass @p
-      = case x of HsExpanded a _ -> hsExprNeedsParens p a
+    go (XExpr x) = case ghcPass @p of
+                     GhcTc -> go_x_tc x
+                     GhcRn -> go_x_rn x
 #if __GLASGOW_HASKELL__ <= 900
-      | otherwise
-      = True
+                     GhcPs -> True
 #endif
 
+    go_x_tc :: XXExprGhcTc -> Bool
+    go_x_tc (WrapExpr (HsWrap _ e))          = hsExprNeedsParens prec e
+    go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a
+    go_x_tc (ConLikeTc {})                   = False
+
+    go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
+    go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a
+
 
 -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,
 -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.
@@ -778,7 +815,6 @@ stripParensHsExpr e = e
 isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool
 -- True of a single token
 isAtomicHsExpr (HsVar {})        = True
-isAtomicHsExpr (HsConLikeOut {}) = True
 isAtomicHsExpr (HsLit {})        = True
 isAtomicHsExpr (HsOverLit {})    = True
 isAtomicHsExpr (HsIPVar {})      = True
@@ -786,12 +822,16 @@ isAtomicHsExpr (HsOverLabel {})  = True
 isAtomicHsExpr (HsUnboundVar {}) = True
 isAtomicHsExpr (HsRecFld{})      = True
 isAtomicHsExpr (XExpr x)
-  | GhcTc <- ghcPass @p          = case x of
-      WrapExpr      (HsWrap _ e)     -> isAtomicHsExpr e
-      ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a
-  | GhcRn <- ghcPass @p          = case x of
-      HsExpanded a _         -> isAtomicHsExpr a
-isAtomicHsExpr _                 = False
+  | GhcTc <- ghcPass @p          = go_x_tc x
+  | GhcRn <- ghcPass @p          = go_x_rn x
+  where
+    go_x_tc (WrapExpr      (HsWrap _ e))     = isAtomicHsExpr e
+    go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a
+    go_x_tc (ConLikeTc {})                   = True
+
+    go_x_rn (HsExpanded a _) = isAtomicHsExpr a
+
+isAtomicHsExpr _ = False
 
 instance Outputable (HsPragE (GhcPass p)) where
   ppr (HsPragSCC _ st (StringLiteral stl lbl _)) =
@@ -1108,21 +1148,27 @@ ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
 ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
-ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
-                                         , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])
-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
-                                         , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
-                                         , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])
-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
-                                         , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm _ op _ _ args)
-  = hang (text "(|" <+> ppr_lexpr op)
-         4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
+ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args)
+  | HsVar _ (L _ v) <- op
+  = ppr_cmd_infix v
+  | GhcTc <- ghcPass @p
+  , XExpr (ConLikeTc c _ _) <- op
+  = ppr_cmd_infix (conLikeName c)
+  | otherwise
+  = fall_through
+  where
+    fall_through = hang (text "(|" <+> ppr_expr op)
+                      4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
+
+    ppr_cmd_infix :: OutputableBndr v => v -> SDoc
+    ppr_cmd_infix v
+      | [arg1, arg2] <- args
+      , isJust rn_fix || ps_fix == Infix
+      = hang (pprCmdArg (unLoc arg1))
+           4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])
+      | otherwise
+      = fall_through
+
 ppr_cmd (XCmd x) = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
   GhcPs -> ppr x