[Git][ghc/ghc][master] Unrestricted OverloadedLabels (#11671)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Oct 12 20:34:17 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
5172789a by Charles Taylor at 2022-10-12T16:33:57-04:00
Unrestricted OverloadedLabels (#11671)
Implements GHC proposal:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst
- - - - -
5 changed files:
- compiler/GHC/Parser/Lexer.x
- docs/users_guide/9.6.1-notes.rst
- + testsuite/tests/overloadedrecflds/should_run/T11671_run.hs
- + testsuite/tests/overloadedrecflds/should_run/T11671_run.stdout
- testsuite/tests/overloadedrecflds/should_run/all.T
Changes:
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -163,6 +163,7 @@ $small = [$ascsmall $unismall \_]
$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].
$idchar = [$small $large $digit $uniidchar \']
+$labelchar = [$small $large $digit $uniidchar \' \.]
$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].
$graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\']
@@ -451,7 +452,8 @@ $tab { warnTab }
}
<0> {
- "#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
+ "#" $labelchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
+ "#" \" / { ifExtension OverloadedLabelsBit } { lex_quoted_label }
}
<0> {
@@ -2023,46 +2025,64 @@ lex_string_prag_comment mkTok span _buf _len _buf2
lex_string_tok :: Action
lex_string_tok span buf _len _buf2 = do
- tok <- lex_string ""
+ lexed <- lex_string
(AI end bufEnd) <- getInput
let
- tok' = case tok of
- ITprimstring _ bs -> ITprimstring (SourceText src) bs
- ITstring _ s -> ITstring (SourceText src) s
- _ -> panic "lex_string_tok"
+ tok = case lexed of
+ LexedPrimString s -> ITprimstring (SourceText src) (unsafeMkByteString s)
+ LexedRegularString s -> ITstring (SourceText src) (mkFastString s)
src = lexemeToString buf (cur bufEnd - cur buf)
- return (L (mkPsSpan (psSpanStart span) end) tok')
+ return $ L (mkPsSpan (psSpanStart span) end) tok
-lex_string :: String -> P Token
-lex_string s = do
+
+lex_quoted_label :: Action
+lex_quoted_label span _buf _len _buf2 = do
+ s <- lex_string_helper ""
+ (AI end _) <- getInput
+ let
+ token = ITlabelvarid (mkFastString s)
+ start = psSpanStart span
+
+ return $ L (mkPsSpan start end) token
+
+
+data LexedString = LexedRegularString String | LexedPrimString String
+
+lex_string :: P LexedString
+lex_string = do
+ s <- lex_string_helper ""
+ magicHash <- getBit MagicHashBit
+ if magicHash
+ then do
+ i <- getInput
+ case alexGetChar' i of
+ Just ('#',i) -> do
+ setInput i
+ when (any (> '\xFF') s) $ do
+ pState <- getPState
+ let msg = PsErrPrimStringInvalidChar
+ let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
+ addError err
+ return $ LexedPrimString s
+ _other ->
+ return $ LexedRegularString s
+ else
+ return $ LexedRegularString s
+
+
+lex_string_helper :: String -> P String
+lex_string_helper s = do
i <- getInput
case alexGetChar' i of
Nothing -> lit_error i
Just ('"',i) -> do
- setInput i
- let s' = reverse s
- magicHash <- getBit MagicHashBit
- if magicHash
- then do
- i <- getInput
- case alexGetChar' i of
- Just ('#',i) -> do
- setInput i
- when (any (> '\xFF') s') $ do
- pState <- getPState
- let msg = PsErrPrimStringInvalidChar
- let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
- addError err
- return (ITprimstring (SourceText s') (unsafeMkByteString s'))
- _other ->
- return (ITstring (SourceText s') (mkFastString s'))
- else
- return (ITstring (SourceText s') (mkFastString s'))
+ setInput i
+ return (reverse s)
Just ('\\',i)
| Just ('&',i) <- next -> do
- setInput i; lex_string s
+ setInput i; lex_string_helper s
| Just (c,i) <- next, c <= '\x7f' && is_space c -> do
-- is_space only works for <= '\x7f' (#3751, #5425)
setInput i; lex_stringgap s
@@ -2070,16 +2090,17 @@ lex_string s = do
Just (c, i1) -> do
case c of
- '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)
- c | isAny c -> do setInput i1; lex_string (c:s)
+ '\\' -> do setInput i1; c' <- lex_escape; lex_string_helper (c':s)
+ c | isAny c -> do setInput i1; lex_string_helper (c:s)
_other -> lit_error i
-lex_stringgap :: String -> P Token
+
+lex_stringgap :: String -> P String
lex_stringgap s = do
i <- getInput
c <- getCharOrFail i
case c of
- '\\' -> lex_string s
+ '\\' -> lex_string_helper s
c | c <= '\x7f' && is_space c -> lex_stringgap s
-- is_space only works for <= '\x7f' (#3751, #5425)
_other -> lit_error i
=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -78,6 +78,15 @@ Language
Then GHC will use the second quantified constraint to solve ``C a b Int``,
as it has a strictly weaker precondition.
+- GHC proposal `#170 Unrestricted OverloadedLabels
+ <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst>`_
+ has been implemented.
+ This extends the variety syntax for constructing labels under :extension:`OverloadedLabels`.
+ Examples of newly allowed syntax:
+ - Leading capital letters: `#Foo` equivalant to `getLabel @"Foo"`
+ - Numeric characters: `#3.14` equivalent to `getLabel @"3.14"`
+ - Arbitrary strings: `#"Hello, World!"` equivalent to `getLabel @"Hello, World!"`
+
Compiler
~~~~~~~~
=====================================
testsuite/tests/overloadedrecflds/should_run/T11671_run.hs
=====================================
@@ -0,0 +1,47 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE MagicHash #-}
+
+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/overloadedrecflds/should_run/T11671_run.stdout
=====================================
@@ -0,0 +1,24 @@
+a
+number17
+do
+type
+Foo
+3
+199.4
+17a23b
+f'a'
+'a'
+'
+''notTHSplice
+...
+привет
+こんにちは
+3
+:
+Foo
+The quick brown fox
+"
+helloworld
+helloworld
+1
+2
=====================================
testsuite/tests/overloadedrecflds/should_run/all.T
=====================================
@@ -17,3 +17,4 @@ test('hasfieldrun01', normal, compile_and_run, [''])
test('hasfieldrun02', normal, compile_and_run, [''])
test('T12243', normal, compile_and_run, [''])
test('T11228', normal, compile_and_run, [''])
+test('T11671_run', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5172789a12dcca65574dc608364a7cbfdec2fe58
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5172789a12dcca65574dc608364a7cbfdec2fe58
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/20221012/e77858f1/attachment-0001.html>
More information about the ghc-commits
mailing list