EPA: Add SourceText to HsOverLabel

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

Close #22771

10 files changed, 35 insertions, 22 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'