Move `ol_witness` to `OverLitTc`

We also add a new `ol_from_fun` field to renamed (but not yet
typechecked) OverLits. This has the nice knock-on effect of making
total some typechecker functions that used to be partial.

Fixes #20151

11 files changed, 79 insertions, 69 deletions

diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index d2f69cc7bb..78a663d7fa 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -415,6 +415,9 @@ deriving instance Data (HsOverLit GhcPs)
 deriving instance Data (HsOverLit GhcRn)
 deriving instance Data (HsOverLit GhcTc)
 
+deriving instance Data OverLitRn
+deriving instance Data OverLitTc
+
 -- ---------------------------------------------------------------------
 -- Data derivations from GHC.Hs.Pat ------------------------------------
 
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
index edab46a5b8..9341827a79 100644
--- a/compiler/GHC/Hs/Lit.hs
+++ b/compiler/GHC/Hs/Lit.hs
@@ -1,10 +1,11 @@
 {-# LANGUAGE ConstraintKinds      #-}
-{-# LANGUAGE DeriveDataTypeable   #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
                                       -- in module Language.Haskell.Syntax.Extension
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, OutputableBndrId
 
@@ -29,11 +30,10 @@ import Language.Haskell.Syntax.Lit
 import GHC.Types.SourceText
 import GHC.Core.Type
 import GHC.Utils.Outputable
+import Language.Haskell.Syntax.Expr ( HsExpr )
 import Language.Haskell.Syntax.Extension
 import GHC.Hs.Extension
 
-import Data.Data hiding ( Fixity )
-
 {-
 ************************************************************************
 *                                                                      *
@@ -57,20 +57,51 @@ type instance XHsFloatPrim  (GhcPass _) = NoExtField
 type instance XHsDoublePrim (GhcPass _) = NoExtField
 type instance XXLit         (GhcPass _) = NoExtCon
 
+data OverLitRn
+  = OverLitRn {
+        ol_rebindable :: Bool,         -- Note [ol_rebindable]
+        ol_from_fun   :: LIdP GhcRn    -- Note [Overloaded literal witnesses]
+        }
+
 data OverLitTc
   = OverLitTc {
-        ol_rebindable :: Bool, -- Note [ol_rebindable]
+        ol_rebindable :: Bool,         -- Note [ol_rebindable]
+        ol_witness    :: HsExpr GhcTc, -- Note [Overloaded literal witnesses]
         ol_type :: Type }
-  deriving Data
+
+{-
+Note [Overloaded literal witnesses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+During renaming, the coercion function needed for a given HsOverLit is
+resolved according to the current scope and RebindableSyntax (see Note
+[ol_rebindable]). The result of this resolution *before* type checking
+is the coercion function such as 'fromInteger' or 'fromRational',
+stored in the ol_from_fun field of OverLitRn.
+
+*After* type checking, the ol_witness field of the OverLitTc contains
+the witness of the literal as HsExpr, such as (fromInteger 3) or
+lit_78. This witness should replace the literal. Reason: it allows
+commoning up of the fromInteger calls, which wouldn't be possible if
+the desugarer made the application.
+
+The ol_type in OverLitTc records the type the overloaded literal is
+found to have.
+-}
 
 type instance XOverLit GhcPs = NoExtField
-type instance XOverLit GhcRn = Bool            -- Note [ol_rebindable]
+type instance XOverLit GhcRn = OverLitRn
 type instance XOverLit GhcTc = OverLitTc
 
+pprXOverLit :: GhcPass p -> XOverLit (GhcPass p) -> SDoc
+pprXOverLit GhcPs noExt = ppr noExt
+pprXOverLit GhcRn OverLitRn{ ol_from_fun = from_fun } = ppr from_fun
+pprXOverLit GhcTc OverLitTc{ ol_witness = witness } = pprExpr witness
+
 type instance XXOverLit (GhcPass _) = NoExtCon
 
 overLitType :: HsOverLit GhcTc -> Type
-overLitType (OverLit (OverLitTc _ ty) _ _) = ty
+overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty
 
 -- | Convert a literal from one index type to another
 convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
@@ -94,8 +125,8 @@ Note [ol_rebindable]
 The ol_rebindable field is True if this literal is actually
 using rebindable syntax.  Specifically:
 
-  False iff ol_witness is the standard one
-  True  iff ol_witness is non-standard
+  False iff ol_from_fun / ol_witness is the standard one
+  True  iff ol_from_fun / ol_witness is non-standard
 
 Equivalently it's True if
   a) RebindableSyntax is on
@@ -127,8 +158,8 @@ pp_st_suffix (SourceText st) suffix _   = text st <> suffix
 -- in debug mode, print the expression that it's resolved to, too
 instance OutputableBndrId p
        => Outputable (HsOverLit (GhcPass p)) where
-  ppr (OverLit {ol_val=val, ol_witness=witness})
-        = ppr val <+> (whenPprDebug (parens (pprExpr witness)))
+  ppr (OverLit {ol_val=val, ol_ext=ext})
+        = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext)))
 
 -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern
 -- match warnings. All are printed the same (i.e., without hashes if they are
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index a0f4fa4c07..87fc46ff12 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -345,9 +345,9 @@ mkRecStmt        :: (Anno [GenLocated
                  -> StmtLR (GhcPass idL) GhcPs bodyR
 
 
-mkHsIntegral     i  = OverLit noExtField (HsIntegral       i) noExpr
-mkHsFractional   f  = OverLit noExtField (HsFractional     f) noExpr
-mkHsIsString src s  = OverLit noExtField (HsIsString   src s) noExpr
+mkHsIntegral     i  = OverLit noExtField (HsIntegral       i)
+mkHsFractional   f  = OverLit noExtField (HsFractional     f)
+mkHsIsString src s  = OverLit noExtField (HsIsString   src s)
 
 mkHsDo     ctxt stmts      = HsDo noAnn ctxt stmts
 mkHsDoAnns ctxt stmts anns = HsDo anns  ctxt stmts
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index 545346e998..c19dceabb8 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -230,8 +230,7 @@ dsRational (n :% d) = do
 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
 -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
 -- (an expression for) the literal value itself.
-dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
-                   , ol_witness = witness }) = do
+dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable witness ty }) = do
   dflags <- getDynFlags
   let platform = targetPlatform dflags
   case shortCutLit platform val ty of
@@ -436,7 +435,7 @@ getLHsIntegralLit (L _ e) = go e
 -- | If 'Integral', extract the value and type of the overloaded literal.
 -- See Note [Literals and the OverloadedLists extension]
 getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc { ol_type = ty } })
   = Just (il_value i, ty)
 getIntegralLit _ = Nothing
 
@@ -521,7 +520,7 @@ tidyLitPat lit = LitPat noExtField lit
 tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
          -> Type
          -> Pat GhcTc
-tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
+tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
         -- False: Take short cuts only if the literal is not using rebindable syntax
         --
         -- Once that is settled, look for cases where the type of the
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 81d3b1cc51..629f32f3cd 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
 
 -- | Desugaring step of the
 -- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
@@ -193,7 +194,7 @@ desugarPat x pat = case pat of
     dflags <- getDynFlags
     let platform = targetPlatform dflags
     pm_lit <- case olit of
-      OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }
+      OverLit{ ol_val = val, ol_ext = OverLitTc { ol_rebindable = rebindable } }
         | not rebindable
         , Just expr <- shortCutLit platform val ty
         -> coreExprAsPmLit <$> dsExpr expr
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index ab9bf28564..534b03e602 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE ViewPatterns        #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -992,8 +993,8 @@ rnOverLit origLit
         ; let std_name = hsOverLitName val
         ; (from_thing_name, fvs1) <- lookupSyntaxName std_name
         ; let rebindable = from_thing_name /= std_name
-              lit' = lit { ol_witness = nl_HsVar from_thing_name
-                         , ol_ext = rebindable }
+              lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable
+                                              , ol_from_fun = noLocA from_thing_name } }
         ; if isNegativeZeroOverLit lit'
           then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
                   ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index cd43111123..78f9b0265a 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+{-# LANGUAGE DisambiguateRecordFields #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
 
@@ -74,7 +75,6 @@ import GHC.Types.SrcLoc
 import GHC.Utils.Misc
 import GHC.Data.Maybe
 import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import Control.Monad
 
@@ -633,8 +633,8 @@ CLong, as it should.
 
 tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
 tcInferOverLit lit@(OverLit { ol_val = val
-                            , ol_witness = HsVar _ (L loc from_name)
-                            , ol_ext = rebindable })
+                            , ol_ext = OverLitRn { ol_rebindable = rebindable
+                                                 , ol_from_fun = L loc from_name } })
   = -- Desugar "3" to (fromInteger (3 :: Integer))
     --   where fromInteger is gotten by looking up from_name, and
     --   the (3 :: Integer) is returned by mkOverLit
@@ -651,8 +651,10 @@ tcInferOverLit lit@(OverLit { ol_val = val
                         HsLit noAnn hs_lit
              from_expr = mkHsWrap (wrap2 <.> wrap1) $
                          HsVar noExtField (L loc from_id)
-             lit' = lit { ol_witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr
-                        , ol_ext = OverLitTc rebindable res_ty }
+             witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr
+             lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable
+                                             , ol_witness = witness
+                                             , ol_type = res_ty } }
        ; return (HsOverLit noAnn lit', res_ty) }
   where
     orig   = LiteralOrigin lit
@@ -660,9 +662,6 @@ tcInferOverLit lit@(OverLit { ol_val = val
     herald = sep [ text "The function" <+> quotes (ppr from_name)
                  , text "is applied to"]
 
-tcInferOverLit lit
-  = pprPanic "tcInferOverLit" (ppr lit)
-
 
 {- *********************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index a80dfb71a5..73c62839e3 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -1,5 +1,6 @@
 
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -677,8 +678,8 @@ newNonTrivialOverloadedLit :: HsOverLit GhcRn
                            -> ExpRhoType
                            -> TcM (HsOverLit GhcTc)
 newNonTrivialOverloadedLit
-  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
-               , ol_ext = rebindable }) res_ty
+  lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L _ meth_name) })
+  res_ty
   = do  { hs_lit <- mkOverLit val
         ; let lit_ty = hsLitType hs_lit
         ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
@@ -686,14 +687,12 @@ newNonTrivialOverloadedLit
                       \_ _ -> return ()
         ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
         ; res_ty <- readExpType res_ty
-        ; return (lit { ol_witness = witness
-                      , ol_ext = OverLitTc rebindable res_ty }) }
+        ; return (lit { ol_ext = OverLitTc { ol_rebindable = rebindable
+                                           , ol_witness = witness
+                                           , ol_type = res_ty } }) }
   where
     orig = LiteralOrigin lit
 
-newNonTrivialOverloadedLit lit _
-  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
-
 ------------
 mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
 mkOverLit (HsIntegral i)
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 49d2885c5e..963fe9f9b1 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -122,15 +122,14 @@ to short-cut the process for built-in types.  We can do this in two places;
 -}
 
 tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
-tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty
+tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn 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 }
+                         lit { ol_ext = OverLitTc False expr res_ty }
             Nothing   -> return Nothing }
   | otherwise
   = return Nothing
@@ -1088,10 +1087,11 @@ zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co
 
 -------------------------------------------------------------------------
 zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
-zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
+zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } })
   = do  { ty' <- zonkTcTypeToTypeX env ty
         ; e' <- zonkExpr env e
-        ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
+        ; return (lit { ol_ext = x { ol_witness = e'
+                                   , ol_type = ty' } }) }
 
 -------------------------------------------------------------------------
 zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)
diff --git a/compiler/Language/Haskell/Syntax/Lit.hs b/compiler/Language/Haskell/Syntax/Lit.hs
index 6e036f4503..3000aa345c 100644
--- a/compiler/Language/Haskell/Syntax/Lit.hs
+++ b/compiler/Language/Haskell/Syntax/Lit.hs
@@ -20,7 +20,6 @@ module Language.Haskell.Syntax.Lit where
 
 import GHC.Prelude
 
-import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr )
 import GHC.Types.Basic (PprPrec(..), topPrec )
 import GHC.Types.SourceText
 import GHC.Core.Type
@@ -100,8 +99,7 @@ instance Eq (HsLit x) where
 data HsOverLit p
   = OverLit {
       ol_ext :: (XOverLit p),
-      ol_val :: OverLitVal,
-      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]
+      ol_val :: OverLitVal}
 
   | XOverLit
       !(XXOverLit p)
@@ -120,28 +118,11 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
 negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
 negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
 
-{-
-Note [Overloaded literal witnesses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-*Before* type checking, the HsExpr in an HsOverLit is the
-name of the coercion function, 'fromInteger' or 'fromRational'.
-*After* type checking, it is a witness for the literal, such as
-        (fromInteger 3) or lit_78
-This witness should replace the literal.
-
-This dual role is unusual, because we're replacing 'fromInteger' with
-a call to fromInteger.  Reason: it allows commoning up of the fromInteger
-calls, which wouldn't be possible if the desugarer made the application.
-
-The PostTcType in each branch records the type the overload literal is
-found to have.
--}
-
 -- Comparison operations are needed when grouping literals
 -- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)
 instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
-  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
-  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2
+  (OverLit _ val1) == (OverLit _ val2) = val1 == val2
+  (XOverLit  val1) == (XOverLit  val2) = val1 == val2
   _ == _ = panic "Eq HsOverLit"
 
 instance Eq OverLitVal where
@@ -151,8 +132,8 @@ instance Eq OverLitVal where
   _                   == _                   = False
 
 instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
-  compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2
-  compare (XOverLit  val1)   (XOverLit  val2)   = val1 `compare` val2
+  compare (OverLit _ val1)  (OverLit _ val2) = val1 `compare` val2
+  compare (XOverLit  val1)  (XOverLit  val2) = val1 `compare` val2
   compare _ _ = panic "Ord HsOverLit"
 
 instance Ord OverLitVal where
diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout
index 7984181504..12c0c7192c 100644
--- a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout
+++ b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout
@@ -1,12 +1,8 @@
 HsIntegral [0003] 3
-HsString [noExpr] "noExpr"
 HsIntegral [0x04] 4
-HsString [noExpr] "noExpr"
 HsString ["\x20"] " "
 HsChar ['\x20'] ' '
-HsString [noExpr] "noExpr"
 HsCharPrim ['\x41'] 'A'
 HsIntPrim [0004#] 4
 HsWordPrim [005##] 5
 HsIntegral [1] 1
-HsString [noExpr] "noExpr"