Unrestricted OverloadedLabels (#11671)

Implements GHC proposal:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst

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, [''])