diff options
author | Charles Taylor <charlestaylor95@gmail.com> | 2022-09-10 16:09:54 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-10-12 16:33:57 -0400 |
commit | 5172789a12dcca65574dc608364a7cbfdec2fe58 (patch) | |
tree | ce513e70677820e50fdd0811dd21de61e4a82263 | |
parent | 626652f7c172f307bd87afaee59c7f0e2825c55d (diff) | |
download | haskell-5172789a12dcca65574dc608364a7cbfdec2fe58.tar.gz |
Unrestricted OverloadedLabels (#11671)
Implements GHC proposal:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst
-rw-r--r-- | compiler/GHC/Parser/Lexer.x | 87 | ||||
-rw-r--r-- | docs/users_guide/9.6.1-notes.rst | 9 | ||||
-rw-r--r-- | testsuite/tests/overloadedrecflds/should_run/T11671_run.hs | 47 | ||||
-rw-r--r-- | testsuite/tests/overloadedrecflds/should_run/T11671_run.stdout | 24 | ||||
-rw-r--r-- | testsuite/tests/overloadedrecflds/should_run/all.T | 1 |
5 files changed, 135 insertions, 33 deletions
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 8e2efe48f0..26f0de2873 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/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 diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst index 1afc9f7093..64d0568b30 100644 --- a/docs/users_guide/9.6.1-notes.rst +++ b/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 ~~~~~~~~ diff --git a/testsuite/tests/overloadedrecflds/should_run/T11671_run.hs b/testsuite/tests/overloadedrecflds/should_run/T11671_run.hs new file mode 100644 index 0000000000..78ebcdca8e --- /dev/null +++ b/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` + ] diff --git a/testsuite/tests/overloadedrecflds/should_run/T11671_run.stdout b/testsuite/tests/overloadedrecflds/should_run/T11671_run.stdout new file mode 100644 index 0000000000..e4d7aed784 --- /dev/null +++ b/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 diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T index 8d6d9850bb..716a616dec 100644 --- a/testsuite/tests/overloadedrecflds/should_run/all.T +++ b/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, ['']) |