[Git][ghc/ghc][master] EPA: Add SourceText to HsOverLabel
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jan 23 09:50:58 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
fec7c2ea by Alan Zimmerman at 2023-01-23T04:50:33-05:00
EPA: Add SourceText to HsOverLabel
To be able to capture string literals with possible escape codes as labels.
Close #22771
- - - - -
18 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/perf/compiler/hard_hole_fits.hs
- testsuite/tests/perf/compiler/hard_hole_fits.stderr
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test22771.hs
- testsuite/tests/printer/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
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)
=====================================
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
=====================================
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
=====================================
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))
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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'
=====================================
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)
=====================================
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) = _
=====================================
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)
=====================================
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
=====================================
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`
+ ]
=====================================
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'])
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fec7c2ea8242773b53b253d9536426f743443944
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fec7c2ea8242773b53b253d9536426f743443944
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230123/ee5f0256/attachment-0001.html>
More information about the ghc-commits
mailing list