Improve handling of overloaded labels, literals, lists etcwip/T19154

When implementing Quick Look I'd failed to remember that overloaded
labels, like #foo, should be treated as a "head", so that they can be
instantiated with Visible Type Application. This caused #19154.

A very similar ticket covers overloaded literals: #19167.

This patch fixes both problems, but (annoyingly, albeit temporarily)
in two different ways.

Overloaded labels

I dealt with overloaded labels by buying fully into the
Rebindable Syntax approach described in GHC.Hs.Expr
Note [Rebindable syntax and HsExpansion].

There is a good overview in GHC.Rename.Expr
Note [Handling overloaded and rebindable constructs].
That module contains much of the payload for this patch.

Specifically:

* Overloaded labels are expanded in the renamer, fixing #19154.
  See Note [Overloaded labels] in GHC.Rename.Expr.

* Left and right sections used to have special code paths in the
  typechecker and desugarer.  Now we just expand them in the
  renamer. This is harder than it sounds.  See GHC.Rename.Expr
  Note [Left and right sections].

* Infix operator applications are expanded in the typechecker,
  specifically in GHC.Tc.Gen.App.splitHsApps.  See
  Note [Desugar OpApp in the typechecker] in that module

* ExplicitLists are expanded in the renamer, when (and only when)
  OverloadedLists is on.

* HsIf is expanded in the renamer when (and only when) RebindableSyntax
  is on.  Reason: the coverage checker treats HsIf specially.  Maybe
  we could instead expand it unconditionally, and fix up the coverage
  checker, but I did not attempt that.

Overloaded literals

Overloaded literals, like numbers (3, 4.2) and strings with
OverloadedStrings, were not working correctly with explicit type
applications (see #19167).  Ideally I'd also expand them in the
renamer, like the stuff above, but I drew back on that because they
can occur in HsPat as well, and I did not want to to do the HsExpanded
thing for patterns.

But they *can* now be the "head" of an application in the typechecker,
and hence something like ("foo" @T) works now.  See
GHC.Tc.Gen.Head.tcInferOverLit.  It's also done a bit more elegantly,
rather than by constructing a new HsExpr and re-invoking the
typechecker. There is some refactoring around tcShortCutLit.

Ultimately there is more to do here, following the Rebindable Syntax
story.

There are a lot of knock-on effects:

* HsOverLabel and ExplicitList no longer need funny (Maybe SyntaxExpr)
  fields to support rebindable syntax -- good!

* HsOverLabel, OpApp, SectionL, SectionR all become impossible in the
  output of the typecheker, GhcTc; so we set their extension fields to
  Void. See GHC.Hs.Expr Note [Constructor cannot occur]

* Template Haskell quotes for HsExpanded is a bit tricky.  See
  Note [Quotation and rebindable syntax] in GHC.HsToCore.Quote.

* In GHC.HsToCore.Match.viewLExprEq, which groups equal HsExprs for the
  purpose of pattern-match overlap checking, I found that dictionary
  evidence for the same type could have two different names.  Easily
  fixed by comparing types not names.

* I did quite a bit of annoying fiddling around in GHC.Tc.Gen.Head and
  GHC.Tc.Gen.App to get error message locations and contexts right,
  esp in splitHsApps, and the HsExprArg type.  Tiresome and not very
  illuminating.  But at least the tricky, higher order, Rebuilder
  function is gone.

* Some refactoring in GHC.Tc.Utils.Monad around contexts and locations
  for rebindable syntax.

* Incidentally fixes #19346, because we now print renamed, rather than
  typechecked, syntax in error mesages about applications.

The commit removes the vestigial module GHC.Builtin.RebindableNames,
and thus triggers a 2.4% metric decrease for test MultiLayerModules
(#19293).

Metric Decrease:
    MultiLayerModules
    T12545

3 files changed, 135 insertions, 84 deletions

diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 80f3a477dd..84e28a75e8 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -12,7 +12,8 @@
 
 module GHC.Tc.Utils.Instantiate (
      topSkolemise,
-     topInstantiate, instantiateSigma,
+     topInstantiate,
+     instantiateSigma,
      instCall, instDFunType, instStupidTheta, instTyVarsWith,
      newWanted, newWanteds,
 
@@ -189,25 +190,25 @@ topSkolemise ty
       = return (wrap, tv_prs, ev_vars, substTy subst ty)
         -- substTy is a quick no-op on an empty substitution
 
--- | Instantiate all outer type variables
--- and any context. Never looks through arrows.
-topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
--- if    topInstantiate ty = (wrap, rho)
--- and   e :: ty
--- then  wrap e :: rho  (that is, wrap :: ty "->" rho)
--- NB: always returns a rho-type, with no top-level forall or (=>)
-topInstantiate orig ty
-  | (tvs, theta, body) <- tcSplitSigmaTy ty
+topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- Instantiate outer invisible binders (both Inferred and Specified)
+-- If    top_instantiate ty = (wrap, inner_ty)
+-- then  wrap :: inner_ty "->" ty
+-- NB: returns a type with no (=>),
+--     and no invisible forall at the top
+topInstantiate orig sigma
+  | (tvs,   body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma
+  , (theta, body2) <- tcSplitPhiTy body1
   , not (null tvs && null theta)
-  = do { (_, wrap1, body1) <- instantiateSigma orig tvs theta body
+  = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2
 
        -- Loop, to account for types like
        --       forall a. Num a => forall b. Ord b => ...
-       ; (wrap2, rho) <- topInstantiate orig body1
+       ; (wrap2, body4) <- topInstantiate orig body3
 
-       ; return (wrap2 <.> wrap1, rho) }
+       ; return (wrap2 <.> wrap1, body4) }
 
-  | otherwise = return (idHsWrapper, ty)
+  | otherwise = return (idHsWrapper, sigma)
 
 instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType
                  -> TcM ([TcTyVar], HsWrapper, TcSigmaType)
@@ -658,34 +659,18 @@ cases (the rest are caught in lookupInst).
 newOverloadedLit :: HsOverLit GhcRn
                  -> ExpRhoType
                  -> TcM (HsOverLit GhcTc)
-newOverloadedLit
-  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
-  | not rebindable
-  = do { res_ty <- expTypeToType res_ty
-       ; dflags <- getDynFlags
-       ; let platform = targetPlatform dflags
-       ; case shortCutLit platform val res_ty of
-        -- Do not generate a LitInst for rebindable syntax.
-        -- Reason: If we do, tcSimplify will call lookupInst, which
-        --         will call tcSyntaxName, which does unification,
-        --         which tcSimplify doesn't like
-           Just expr -> return (lit { ol_witness = expr
-                                    , ol_ext = OverLitTc False res_ty })
-           Nothing   -> newNonTrivialOverloadedLit orig lit
-                                                   (mkCheckExpType res_ty) }
-
-  | otherwise
-  = newNonTrivialOverloadedLit orig lit res_ty
-  where
-    orig = LiteralOrigin lit
+newOverloadedLit lit res_ty
+  = do { mb_lit' <- tcShortCutLit lit res_ty
+       ; case mb_lit' of
+            Just lit' -> return lit'
+            Nothing   -> newNonTrivialOverloadedLit lit res_ty }
 
 -- Does not handle things that 'shortCutLit' can handle. See also
 -- newOverloadedLit in GHC.Tc.Utils.Unify
-newNonTrivialOverloadedLit :: CtOrigin
-                           -> HsOverLit GhcRn
+newNonTrivialOverloadedLit :: HsOverLit GhcRn
                            -> ExpRhoType
                            -> TcM (HsOverLit GhcTc)
-newNonTrivialOverloadedLit orig
+newNonTrivialOverloadedLit
   lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
                , ol_ext = rebindable }) res_ty
   = do  { hs_lit <- mkOverLit val
@@ -697,7 +682,10 @@ newNonTrivialOverloadedLit orig
         ; res_ty <- readExpType res_ty
         ; return (lit { ol_witness = witness
                       , ol_ext = OverLitTc rebindable res_ty }) }
-newNonTrivialOverloadedLit _ lit _
+  where
+    orig = LiteralOrigin lit
+
+newNonTrivialOverloadedLit lit _
   = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
 
 ------------
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 0c276d9e16..493602fea0 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -896,19 +896,23 @@ getSrcSpanM :: TcRn SrcSpan
         -- Avoid clash with Name.getSrcLoc
 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }
 
--- See Note [Rebindable syntax and HsExpansion].
+-- See Note [Error contexts in generated code]
 inGeneratedCode :: TcRn Bool
 inGeneratedCode = tcl_in_gen_code <$> getLclEnv
 
 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-setSrcSpan (RealSrcSpan loc _) thing_inside =
-  updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
-            thing_inside
+-- See Note [Error contexts in generated code]
+-- for the tcl_in_gen_code manipulation
+setSrcSpan (RealSrcSpan loc _) thing_inside
+  = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
+              thing_inside
+
 setSrcSpan loc@(UnhelpfulSpan _) thing_inside
-  -- See Note [Rebindable syntax and HsExpansion].
-  | isGeneratedSrcSpan loc =
-      updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
-  | otherwise = thing_inside
+  | isGeneratedSrcSpan loc
+  = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
+
+  | otherwise
+  = thing_inside
 
 addLocM :: (a -> TcM b) -> Located a -> TcM b
 addLocM fn (L loc a) = setSrcSpan loc $ fn a
@@ -1101,7 +1105,20 @@ is applied to four arguments.  See #18379 for a concrete example.
 This reliance on delicate inlining and Called Arity is not good.
 See #18202 for a more general approach.  But meanwhile, these
 ininings seem unobjectional, and they solve the immediate
-problem. -}
+problem.
+
+Note [Error contexts in generated code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
+  and back to False when we get a useful SrcSpan
+
+* When tc_in_gen_code is True, addErrCtxt becomes a no-op.
+
+So typically it's better to do setSrcSpan /before/ addErrCtxt.
+
+See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for
+more discussion of this fancy footwork.
+-}
 
 getErrCtxt :: TcM [ErrCtxt]
 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
@@ -1119,7 +1136,7 @@ addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 -- | Add a message to the error context. This message may do tidying.
 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
 {-# INLINE addErrCtxtM #-}  -- Note [Inlining addErrCtxt]
-addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m
+addErrCtxtM ctxt = pushCtxt (False, ctxt)
 
 -- | Add a fixed landmark message to the error context. A landmark
 -- message is always sure to be reported, even if there is a lot of
@@ -1133,24 +1150,25 @@ addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
 -- and tidying.
 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
 {-# INLINE addLandmarkErrCtxtM #-}  -- Note [Inlining addErrCtxt]
-addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m
-
-push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, SDoc))
-          -> Bool -> [ErrCtxt] -> [ErrCtxt]
-push_ctxt ctxt in_gen ctxts
-  | in_gen    = ctxts
-  | otherwise = ctxt : ctxts
-
-updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
-{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt]
--- Helper function for the above
--- The Bool is true if we are in generated code
-updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt
-                                         , tcl_in_gen_code = in_gen }) ->
-                           env { tcl_ctxt = upd in_gen ctxt })
+addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt)
+
+pushCtxt :: ErrCtxt -> TcM a -> TcM a
+{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
+pushCtxt ctxt = updLclEnv (updCtxt ctxt)
+
+updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
+-- Do not update the context if we are in generated code
+-- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen })
+  | in_gen    = env
+  | otherwise = env { tcl_ctxt = ctxt : ctxts }
 
 popErrCtxt :: TcM a -> TcM a
-popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
+popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
+                          env { tcl_ctxt = pop ctxt })
+           where
+             pop []       = []
+             pop (_:msgs) = msgs
 
 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
 getCtLocM origin t_or_k
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 4fb5286c70..aad5299bbf 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -20,7 +20,7 @@ module GHC.Tc.Utils.Zonk (
         -- * Other HsSyn functions
         mkHsDictLet, mkHsApp,
         mkHsAppTy, mkHsCaseAlt,
-        shortCutLit, hsOverLitName,
+        tcShortCutLit, shortCutLit, hsOverLitName,
         conLikeResTy,
 
         -- * re-exported from TcMonad
@@ -90,6 +90,7 @@ import GHC.Types.Basic
 import GHC.Types.SrcLoc
 import GHC.Types.Unique.FM
 import GHC.Types.TyThing
+import GHC.Driver.Session( getDynFlags, targetPlatform )
 
 import GHC.Data.Maybe
 import GHC.Data.Bag
@@ -151,28 +152,75 @@ hsLitType (HsRat _ _ ty)     = ty
 hsLitType (HsFloatPrim _ _)  = floatPrimTy
 hsLitType (HsDoublePrim _ _) = doublePrimTy
 
+{- *********************************************************************
+*                                                                      *
+         Short-cuts for overloaded numeric literals
+*                                                                      *
+********************************************************************* -}
+
 -- Overloaded literals. Here mainly because it uses isIntTy etc
 
+{- Note [Short cut for overloaded literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)).
+But if we have a list like
+  [4,2,3,2,4,4,2]::[Int]
+we use a lot of compile time and space generating and solving all those Num
+constraints, and generating calls to fromInteger etc.  Better just to cut to
+the chase, and cough up an Int literal. Large collections of literals like this
+sometimes appear in source files, so it's quite a worthwhile fix.
+
+So we try to take advantage of whatever nearby type information we have,
+to short-cut the process for built-in types.  We can do this in two places;
+
+* In the typechecker, when we are about to typecheck the literal.
+* If that fails, in the desugarer, once we know the final type.
+-}
+
+tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
+tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty
+  | not rebindable
+  , Just res_ty <- checkingExpType_maybe exp_res_ty
+  = do { dflags <- getDynFlags
+       ; let platform = targetPlatform dflags
+       ; case shortCutLit platform val res_ty of
+            Just expr -> return $ Just $
+                         lit { ol_witness = expr
+                             , ol_ext = OverLitTc False res_ty }
+            Nothing   -> return Nothing }
+  | otherwise
+  = return Nothing
+
 shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc)
-shortCutLit platform (HsIntegral int@(IL src neg i)) ty
-  | isIntTy ty  && platformInIntRange  platform i = Just (HsLit noExtField (HsInt noExtField int))
-  | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i))
-  | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty))
-  | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty
+shortCutLit platform val res_ty
+  = case val of
+      HsIntegral int_lit    -> go_integral int_lit
+      HsFractional frac_lit -> go_fractional frac_lit
+      HsIsString s src      -> go_string   s src
+  where
+    go_integral int@(IL src neg i)
+      | isIntTy res_ty  && platformInIntRange  platform i
+      = Just (HsLit noExtField (HsInt noExtField int))
+      | isWordTy res_ty && platformInWordRange platform i
+      = Just (mkLit wordDataCon (HsWordPrim src i))
+      | isIntegerTy res_ty
+      = Just (HsLit noExtField (HsInteger src i res_ty))
+      | otherwise
+      = go_fractional (integralFractionalLit neg i)
         -- The 'otherwise' case is important
         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
         -- so we'll call shortCutIntLit, but of course it's a float
         -- This can make a big difference for programs with a lot of
         -- literals, compiled without -O
 
-shortCutLit _ (HsFractional f) ty
-  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExtField f))
-  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
-  | otherwise     = Nothing
+    go_fractional f
+      | isFloatTy res_ty  = Just (mkLit floatDataCon  (HsFloatPrim noExtField f))
+      | isDoubleTy res_ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
+      | otherwise         = Nothing
 
-shortCutLit _ (HsIsString src s) ty
-  | isStringTy ty = Just (HsLit noExtField (HsString src s))
-  | otherwise     = Nothing
+    go_string src s
+      | isStringTy res_ty = Just (HsLit noExtField (HsString src s))
+      | otherwise         = Nothing
 
 mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
 mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit)
@@ -881,13 +929,10 @@ zonkExpr env (HsDo ty do_or_lc (L l stmts))
        new_ty <- zonkTcTypeToTypeX env ty
        return (HsDo new_ty do_or_lc (L l new_stmts))
 
-zonkExpr env (ExplicitList ty wit exprs)
-  = do (env1, new_wit) <- zonkWit env wit
-       new_ty <- zonkTcTypeToTypeX env1 ty
-       new_exprs <- zonkLExprs env1 exprs
-       return (ExplicitList new_ty new_wit new_exprs)
-   where zonkWit env Nothing    = return (env, Nothing)
-         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+zonkExpr env (ExplicitList ty exprs)
+  = do new_ty <- zonkTcTypeToTypeX env ty
+       new_exprs <- zonkLExprs env exprs
+       return (ExplicitList new_ty new_exprs)
 
 zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds })
   = do  { new_con_expr <- zonkExpr env con_expr