EPA: Add SourceText to HsOverLabelwip/az/ppr-overloaded-labels

To be able to capture string literals with possible escape codes as labels.

Close #22771

18 files changed, 107 insertions, 32 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 31d67c308c..621848920d 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -489,7 +489,9 @@ ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v
 ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv
 ppr_expr (HsRecSel _ f)      = pprPrefixOcc f
 ppr_expr (HsIPVar _ v)       = ppr v
-ppr_expr (HsOverLabel _ l)   = char '#' <> ppr l
+ppr_expr (HsOverLabel _ s l) = char '#' <> case s of
+                                             NoSourceText -> ppr l
+                                             SourceText src -> text src
 ppr_expr (HsLit _ lit)       = ppr lit
 ppr_expr (HsOverLit _ lit)   = ppr lit
 ppr_expr (HsPar _ _ e _)     = parens (ppr_lexpr e)
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 6310a0f3c9..a7e21d2458 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -94,7 +94,7 @@ hsExprType :: HsExpr GhcTc -> Type
 hsExprType (HsVar _ (L _ id)) = idType id
 hsExprType (HsUnboundVar (HER _ ty _) _) = ty
 hsExprType (HsRecSel _ (FieldOcc id _)) = idType id
-hsExprType (HsOverLabel v _) = dataConCantHappen v
+hsExprType (HsOverLabel v _ _) = dataConCantHappen v
 hsExprType (HsIPVar v _) = dataConCantHappen v
 hsExprType (HsOverLit _ lit) = overLitType lit
 hsExprType (HsLit _ lit) = hsLitType lit
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 52a7822c1e..da3d1f4dac 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -525,10 +525,10 @@ dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
 -- HsSyn constructs that just shouldn't be here, because
 -- the renamer removed them.  See GHC.Rename.Expr.
 -- Note [Handling overloaded and rebindable constructs]
-dsExpr (HsOverLabel x _) = dataConCantHappen x
-dsExpr (OpApp x _ _ _)   = dataConCantHappen x
-dsExpr (SectionL x _ _)  = dataConCantHappen x
-dsExpr (SectionR x _ _)  = dataConCantHappen x
+dsExpr (HsOverLabel x _ _) = dataConCantHappen x
+dsExpr (OpApp x _ _ _)     = dataConCantHappen x
+dsExpr (SectionL x _ _)    = dataConCantHappen x
+dsExpr (SectionR x _ _)    = dataConCantHappen x
 
 ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
 ds_prag_expr (HsPragSCC _ cc) expr = do
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index f6cf36101b..63094c21dd 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1508,7 +1508,7 @@ repE (HsVar _ (L _ x)) =
         Just (DsSplice e)  -> do { e' <- lift $ dsExpr e
                                  ; return (MkC e') } }
 repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
-repE (HsOverLabel _ s) = repOverLabel s
+repE (HsOverLabel _ _ s) = repOverLabel s
 
 repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))
 
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 16b6519788..0f50241bd6 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -707,7 +707,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
  MDO            { L _ (ITmdo _) }
 
  IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension
- LABELVARID     { L _ (ITlabelvarid   _) }
+ LABELVARID     { L _ (ITlabelvarid _ _) }
 
  CHAR           { L _ (ITchar   _ _) }
  STRING         { L _ (ITstring _ _) }
@@ -2908,7 +2908,7 @@ aexp2   :: { ECP }
         | qcon                          { ECP $ mkHsVarPV $! $1 }
         -- See Note [%shift: aexp2 -> ipvar]
         | ipvar %shift                  {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) }
-        | overloaded_label              {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) $! unLoc $1)) }
+        | overloaded_label              {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) (fst $! unLoc $1) (snd $! unLoc $1))) }
         | literal                       { ECP $ pvA (mkHsLitPV $! $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
 -- into HsOverLit when -XOverloadedStrings is on.
@@ -3494,8 +3494,8 @@ ipvar   :: { Located HsIPName }
 -----------------------------------------------------------------------------
 -- Overloaded labels
 
-overloaded_label :: { Located FastString }
-        : LABELVARID          { sL1 $1 (getLABELVARID $1) }
+overloaded_label :: { Located (SourceText, FastString) }
+        : LABELVARID          { sL1 $1 (getLABELVARIDs $1, getLABELVARID $1) }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations
@@ -3923,7 +3923,7 @@ getQCONID       (L _ (ITqconid   x)) = x
 getQVARSYM      (L _ (ITqvarsym  x)) = x
 getQCONSYM      (L _ (ITqconsym  x)) = x
 getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
-getLABELVARID   (L _ (ITlabelvarid   x)) = x
+getLABELVARID   (L _ (ITlabelvarid _ x)) = x
 getCHAR         (L _ (ITchar   _ x)) = x
 getSTRING       (L _ (ITstring _ x)) = x
 getINTEGER      (L _ (ITinteger x))  = x
@@ -3948,6 +3948,8 @@ getPRIMSTRINGs  (L _ (ITprimstring src _)) = src
 getPRIMINTEGERs (L _ (ITprimint    src _)) = src
 getPRIMWORDs    (L _ (ITprimword   src _)) = src
 
+getLABELVARIDs   (L _ (ITlabelvarid src _)) = src
+
 -- See Note [Pragma source text] in "GHC.Types.Basic" for the following
 getINLINE_PRAGs       (L _ (ITinline_prag       _ inl _)) = inlineSpecSource inl
 getOPAQUE_PRAGs       (L _ (ITopaque_prag       src))     = src
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 0f0f37075f..a5af14a8ba 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -455,7 +455,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
 }
 
 <0> {
-  "#" $labelchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
+  "#" $labelchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid_src ITlabelvarid }
   "#" \" / { ifExtension OverloadedLabelsBit } { lex_quoted_label }
 }
 
@@ -853,7 +853,10 @@ data Token
   | ITqconsym (FastString,FastString)
 
   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
-  | ITlabelvarid   FastString   -- Overloaded label: #x
+  | ITlabelvarid SourceText FastString   -- Overloaded label: #x
+                                         -- The SourceText is required because we can
+                                         -- have a string literal as a label
+                                         -- Note [Literal source text] in "GHC.Types.Basic"
 
   | ITchar     SourceText Char       -- Note [Literal source text] in "GHC.Types.Basic"
   | ITstring   SourceText FastString -- Note [Literal source text] in "GHC.Types.Basic"
@@ -1114,6 +1117,11 @@ skip_one_varid :: (FastString -> Token) -> Action
 skip_one_varid f span buf len _buf2
   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
 
+skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action
+skip_one_varid_src f span buf len _buf2
+  = return (L span $! f (SourceText $ lexemeToString (stepOn buf) (len-1))
+                        (lexemeToFastString (stepOn buf) (len-1)))
+
 skip_two_varid :: (FastString -> Token) -> Action
 skip_two_varid f span buf len _buf2
   = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))
@@ -2032,12 +2040,13 @@ lex_string_tok span buf _len _buf2 = do
 
 
 lex_quoted_label :: Action
-lex_quoted_label span _buf _len _buf2 = do
+lex_quoted_label span buf _len _buf2 = do
   start <- getInput
   s <- lex_string_helper "" start
-  (AI end _) <- getInput
+  (AI end bufEnd) <- getInput
   let
-    token = ITlabelvarid (mkFastString s)
+    token = ITlabelvarid (SourceText src) (mkFastString s)
+    src = lexemeToString (stepOn buf) (cur bufEnd - cur buf - 1)
     start = psSpanStart span
 
   return $ L (mkPsSpan start end) token
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 95931ca4a1..24462a21bc 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -284,9 +284,9 @@ rnExpr (HsUnboundVar _ v)
   = return (HsUnboundVar noExtField v, emptyFVs)
 
 -- HsOverLabel: see Note [Handling overloaded and rebindable constructs]
-rnExpr (HsOverLabel _ v)
+rnExpr (HsOverLabel _ src v)
   = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
-       ; return ( mkExpandedExpr (HsOverLabel noAnn v) $
+       ; return ( mkExpandedExpr (HsOverLabel noAnn src v) $
                   HsAppType noExtField (genLHsVar from_label) noHsTok hs_ty_arg
                 , fvs ) }
   where
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 4a40528f1f..ae6a618c37 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -680,7 +680,7 @@ exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
 exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (field_label $ unLoc $ dfoLabel f)
 exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable"
 exprCtOrigin (HsRecSel _ f)       = OccurrenceOfRecSel (unLoc $ foLabel f)
-exprCtOrigin (HsOverLabel _ l)    = OverLabelOrigin l
+exprCtOrigin (HsOverLabel _ _ l)  = OverLabelOrigin l
 exprCtOrigin (ExplicitList {})    = ListOrigin
 exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip
 exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 8c95d6f297..f9ab10b6d0 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -745,7 +745,7 @@ zonkExpr env (HsRecSel _ (FieldOcc v occ))
 
 zonkExpr _ (HsIPVar x _) = dataConCantHappen x
 
-zonkExpr _ (HsOverLabel x _) = dataConCantHappen x
+zonkExpr _ (HsOverLabel x _ _) = dataConCantHappen x
 
 zonkExpr env (HsLit x (HsRat e f ty))
   = do new_ty <- zonkTcTypeToTypeX env ty
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 4733768ad6..498a17694f 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1122,7 +1122,7 @@ cvtl e = wrapLA (cvt e)
                               -- constructor names - see #14627.
                               { s' <- vcName s
                               ; wrapParLA (HsVar noExtField) s' }
-    cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)
+    cvt (LabelE s)       = return $ HsOverLabel noComments NoSourceText (fsLit s)
     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }
     cvt (GetFieldE exp f) = do { e' <- cvtl exp
                                ; return $ HsGetField noComments e'
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 5ac3e33bdf..1af91044dd 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -31,7 +31,7 @@ import Language.Haskell.Syntax.Binds
 
 -- others:
 import GHC.Types.Fixity (LexicalFixity(Infix), Fixity)
-import GHC.Types.SourceText (StringLiteral)
+import GHC.Types.SourceText (StringLiteral, SourceText)
 
 import GHC.Unit.Module (ModuleName)
 import GHC.Data.FastString (FastString)
@@ -271,8 +271,9 @@ data HsExpr p
                            -- See Note [Non-overloaded record field selectors] and
                            -- Note [Record selectors in the AST]
 
-  | HsOverLabel (XOverLabel p) FastString
+  | HsOverLabel (XOverLabel p) SourceText FastString
      -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
+     -- Note [Pragma source text] in GHC.Types.SourceText
 
   | HsIPVar   (XIPVar p)
               HsIPName   -- ^ Implicit parameter (not in use after typechecking)
diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.hs b/testsuite/tests/perf/compiler/hard_hole_fits.hs
index 59d08c7f24..341dad1f17 100644
--- a/testsuite/tests/perf/compiler/hard_hole_fits.hs
+++ b/testsuite/tests/perf/compiler/hard_hole_fits.hs
@@ -13,7 +13,7 @@ import GHC (GhcPs)
 testMe :: HsExpr GhcPs -> Int
 testMe (HsVar a b) = _
 testMe (HsUnboundVar xuv uv) = _
-testMe (HsOverLabel xol m_ip) = _
+testMe (HsOverLabel xol s m_ip) = _
 testMe (HsIPVar xv hin) = _
 testMe (HsOverLit xole hol) = _
 testMe (HsLit xle hl) = _
diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
index 9d4e926892..bfabc44219 100644
--- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr
+++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
@@ -37,11 +37,13 @@ hard_hole_fits.hs:15:32: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
           (imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
            (and originally defined in ‘GHC.Enum’))
 
-hard_hole_fits.hs:16:33: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:16:35: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
     • Found hole: _ :: Int
-    • In an equation for ‘testMe’: testMe (HsOverLabel xol m_ip) = _
+    • In an equation for ‘testMe’: testMe (HsOverLabel xol s m_ip) = _
     • Relevant bindings include
         m_ip :: GHC.Data.FastString.FastString
+          (bound at hard_hole_fits.hs:16:27)
+        s :: GHC.Types.SourceText.SourceText
           (bound at hard_hole_fits.hs:16:25)
         xol :: Language.Haskell.Syntax.Extension.XOverLabel GhcPs
           (bound at hard_hole_fits.hs:16:21)
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index dfe29ea25d..de88dea3f0 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -781,3 +781,7 @@ Test22765:
 	$(CHECK_PPR)   $(LIBDIR) Test22765.hs
 	$(CHECK_EXACT) $(LIBDIR) Test22765.hs
 
+.PHONY: Test22771
+Test22771:
+	$(CHECK_PPR)   $(LIBDIR) Test22771.hs
+	$(CHECK_EXACT) $(LIBDIR) Test22771.hs
diff --git a/testsuite/tests/printer/Test22771.hs b/testsuite/tests/printer/Test22771.hs
new file mode 100644
index 0000000000..b935a511d0
--- /dev/null
+++ b/testsuite/tests/printer/Test22771.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedLabels      #-}
+{-# LANGUAGE MagicHash             #-}
+
+module Test22771 where
+
+import Data.Foldable (traverse_)
+import Data.Proxy (Proxy(..))
+import GHC.OverloadedLabels (IsLabel(..))
+import GHC.TypeLits (KnownSymbol, symbolVal)
+import GHC.Prim (Addr#)
+
+instance KnownSymbol symbol => IsLabel symbol String where
+  fromLabel = symbolVal (Proxy :: Proxy symbol)
+
+(#) :: String -> Int -> String
+(#) _ i = show i
+
+f :: Addr# -> Int -> String
+f _ i = show i
+
+main :: IO ()
+main = traverse_ putStrLn
+  [ #a
+  , #number17
+  , #do
+  , #type
+  , #Foo
+  , #3
+  , #199.4
+  , #17a23b
+  , #f'a'
+  , #'a'
+  , #'
+  , #''notTHSplice
+  , #...
+  , #привет
+  , #こんにちは
+  , #"3"
+  , #":"
+  , #"Foo"
+  , #"The quick brown fox"
+  , #"\""
+  , (++) #hello#world
+  , (++) #"hello"#"world"
+  , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1`
+  , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2`
+  ]
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index cc4e4b3324..619a781810 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -188,4 +188,4 @@ test('T20531', extra_files(['T20531_defs.hs']), ghci_script, ['T20531.script'])
 test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_red_ticks.script'])
 test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
 test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
-test('T22785', normal, compile_fail, [''])
+test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 0724da1ef9..be7bb54c0d 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -2638,7 +2638,7 @@ instance ExactPrint (HsExpr GhcPs) where
   getAnnotationEntry (HsVar{})                    = NoEntryVal
   getAnnotationEntry (HsUnboundVar an _)          = fromAnn an
   getAnnotationEntry (HsRecSel{})                 = NoEntryVal
-  getAnnotationEntry (HsOverLabel an _)           = fromAnn an
+  getAnnotationEntry (HsOverLabel an _ _)         = fromAnn an
   getAnnotationEntry (HsIPVar an _)               = fromAnn an
   getAnnotationEntry (HsOverLit an _)             = fromAnn an
   getAnnotationEntry (HsLit an _)                 = fromAnn an
@@ -2676,7 +2676,7 @@ instance ExactPrint (HsExpr GhcPs) where
   setAnnotationAnchor a@(HsVar{})              _ _s = a
   setAnnotationAnchor (HsUnboundVar an a)    anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a)
   setAnnotationAnchor a@(HsRecSel{})           _ _s  = a
-  setAnnotationAnchor (HsOverLabel an a)     anc cs = (HsOverLabel (setAnchorEpa an anc cs) a)
+  setAnnotationAnchor (HsOverLabel an s a)   anc cs = (HsOverLabel (setAnchorEpa an anc cs) s a)
   setAnnotationAnchor (HsIPVar an a)         anc cs = (HsIPVar (setAnchorEpa an anc cs) a)
   setAnnotationAnchor (HsOverLit an a)       anc cs = (HsOverLit (setAnchorEpa an anc cs) a)
   setAnnotationAnchor (HsLit an a)           anc cs = (HsLit (setAnchorEpa an anc cs) a)
@@ -2722,7 +2722,12 @@ instance ExactPrint (HsExpr GhcPs) where
         printStringAtAA l  "_" >> return ()
         printStringAtAA cb "`" >> return ()
         return x
-  exact x@(HsOverLabel _ _) = withPpr x
+  exact x@(HsOverLabel _ src l) = do
+    printStringAtLsDelta (SameLine 0) "#"
+    case src of
+      NoSourceText   -> printStringAtLsDelta (SameLine 0) (unpackFS l)
+      SourceText txt -> printStringAtLsDelta (SameLine 0) txt
+    return x
 
   exact x@(HsIPVar _ (HsIPName n))
     = printStringAdvance ("?" ++ unpackFS n) >> return x
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index d9d7feceac..c4eedde74a 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -204,7 +204,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
  -- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
  -- "../../testsuite/tests/printer/Test16279.hs" Nothing
  -- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
- "../../testsuite/tests/printer/Test22765.hs" Nothing
+--  "../../testsuite/tests/printer/Test22765.hs" Nothing
+ "../../testsuite/tests/printer/Test22771.hs" Nothing
 
 -- cloneT does not need a test, function can be retired