Commit fec7c2ea authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Marge Bot
Browse files

EPA: Add SourceText to HsOverLabel

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

Close #22771
parent a83ec778
Pipeline #61936 canceled with stages
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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'
......
......@@ -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)
......
......@@ -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) = _
......
......@@ -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)
......
......@@ -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
{-# 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`
]
......@@ -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'])
......@@ -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
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment