[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: remove name shadowing
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Oct 12 18:12:29 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4925cf1d by Curran McConnell at 2022-10-12T14:12:02-04:00
remove name shadowing
- - - - -
59cc893b by Tamar Christina at 2022-10-12T14:12:07-04:00
winio: do not re-translate input when handle is uncooked
- - - - -
5327ef91 by Charles Taylor at 2022-10-12T14:12:09-04:00
Unrestricted OverloadedLabels (#11671)
Implements GHC proposal:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst
- - - - -
7 changed files:
- compiler/GHC/Parser/Lexer.x
- docs/users_guide/9.6.1-notes.rst
- ghc/GHCi/UI/Monad.hs
- libraries/base/GHC/IO/Windows/Handle.hsc
- + 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
~~~~~~~~
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -1,6 +1,5 @@
{-# LANGUAGE FlexibleInstances, DeriveFunctor, DerivingVia #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS -fno-warn-name-shadowing #-}
-----------------------------------------------------------------------------
--
@@ -474,10 +473,10 @@ printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
Just allocs ->
text (separateThousands allocs) <+> text "bytes")))
where
- separateThousands n = reverse . sep . reverse . show $ n
- where sep n'
+ separateThousands n = reverse . separate . reverse . show $ n
+ where separate n'
| n' `lengthAtMost` 3 = n'
- | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
+ | otherwise = take 3 n' ++ "," ++ separate (drop 3 n')
-----------------------------------------------------------------------------
-- reverting CAFs
@@ -526,13 +525,13 @@ turnOffBuffering_ fhv = do
liftIO $ evalIO interp fhv
mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
-mkEvalWrapper progname args =
+mkEvalWrapper progname' args' =
runInternal $ GHC.compileParsedExprRemote
- $ evalWrapper `GHC.mkHsApp` nlHsString progname
- `GHC.mkHsApp` nlList (map nlHsString args)
+ $ evalWrapper' `GHC.mkHsApp` nlHsString progname'
+ `GHC.mkHsApp` nlList (map nlHsString args')
where
nlHsString = nlHsLit . mkHsString
- evalWrapper =
+ evalWrapper' =
GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")
-- | Run a 'GhcMonad' action to compile an expression for internal usage.
=====================================
libraries/base/GHC/IO/Windows/Handle.hsc
=====================================
@@ -576,24 +576,23 @@ consoleWriteNonBlocking hwnd ptr _offset bytes
consoleRead :: Bool -> Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int
consoleRead blocking hwnd ptr _offset bytes
- = withUTF16ToGhcInternal ptr bytes $ \reqBytes w_ptr ->
- alloca $ \res -> do
- cooked <- isCooked hwnd
- -- Cooked input must be handled differently when the STD handles are
- -- attached to a real console handle. For File based handles we can't do
- -- proper cooked inputs, but since the actions are async you would get
- -- results as soon as available.
- --
- -- For console handles We have to use a lower level API then ReadConsole,
- -- namely we must use ReadConsoleInput which requires us to process
- -- all console message manually.
- --
- -- Do note that MSYS2 shells such as bash don't attach to a real handle,
- -- and instead have by default a pipe/file based std handles. Which
- -- means the cooked behaviour is best when used in a native Windows
- -- terminal such as cmd, powershell or ConEmu.
- case cooked || not blocking of
- False -> do
+ = alloca $ \res -> do
+ cooked <- isCooked hwnd
+ -- Cooked input must be handled differently when the STD handles are
+ -- attached to a real console handle. For File based handles we can't do
+ -- proper cooked inputs, but since the actions are async you would get
+ -- results as soon as available.
+ --
+ -- For console handles We have to use a lower level API then ReadConsole,
+ -- namely we must use ReadConsoleInput which requires us to process
+ -- all console message manually.
+ --
+ -- Do note that MSYS2 shells such as bash don't attach to a real handle,
+ -- and instead have by default a pipe/file based std handles. Which
+ -- means the cooked behaviour is best when used in a native Windows
+ -- terminal such as cmd, powershell or ConEmu.
+ case cooked || not blocking of
+ False -> withUTF16ToGhcInternal ptr bytes $ \reqBytes w_ptr -> do
debugIO "consoleRead :: un-cooked I/O read."
-- eotControl allows us to handle control characters like EOL
-- without needing a newline, which would sort of defeat the point
@@ -628,9 +627,9 @@ consoleRead blocking hwnd ptr _offset bytes
-- characters as they are. Technically this function can handle any
-- console event. Including mouse, window and virtual key events
-- but for now I'm only interested in key presses.
- let entries = fromIntegral $ reqBytes `div` (#size INPUT_RECORD)
+ let entries = fromIntegral $ bytes `div` (#size INPUT_RECORD)
allocaBytes entries $ \p_inputs ->
- maybeReadEvent p_inputs entries res w_ptr
+ maybeReadEvent p_inputs entries res ptr
-- Check to see if we have been explicitly asked to do a non-blocking
-- I/O, and if we were, make sure that if we didn't have any console
@@ -657,6 +656,7 @@ consoleRead blocking hwnd ptr _offset bytes
b_read <- fromIntegral <$> peek res
read <- cobble b_read w_ptr p_inputs
+ debugIO $ "readEvent: =" ++ show read
if read > 0
then return $ fromIntegral read
else maybeReadEvent p_inputs entries res w_ptr
@@ -665,7 +665,7 @@ consoleRead blocking hwnd ptr _offset bytes
-- minimum required to know which key/sequences were pressed. To do
-- this and prevent having to fully port the PINPUT_RECORD structure
-- in Haskell we use some GCC builtins to find the correct offsets.
- cobble :: Int -> Ptr Word16 -> PINPUT_RECORD -> IO Int
+ cobble :: Int -> Ptr Word8 -> PINPUT_RECORD -> IO Int
cobble 0 _ _ = do debugIO "cobble: done."
return 0
cobble n w_ptr p_inputs =
@@ -690,8 +690,18 @@ consoleRead blocking hwnd ptr _offset bytes
debugIO $ "cobble: offset - " ++ show char_offset
debugIO $ "cobble: show > " ++ show char
debugIO $ "cobble: repeat: " ++ show repeated
+ -- The documentation here is rather subtle, but
+ -- according to MSDN the uWChar being provided here
+ -- has been "translated". What this actually means
+ -- is that the surrogate pairs have already been
+ -- translated into byte sequences. That is, despite
+ -- the Word16 storage type, it's actually a byte
+ -- stream. This means we shouldn't try to decode
+ -- to UTF-8 again since we'd end up incorrectly
+ -- interpreting two bytes as an extended unicode
+ -- character.
pokeArray w_ptr $ replicate repeated char
- (+1) <$> cobble n' w_ptr' p_inputs'
+ (+repeated) <$> cobble n' w_ptr' p_inputs'
else do debugIO $ "cobble: skip event."
cobble n' w_ptr p_inputs'
=====================================
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/-/compare/f3799362d9a5582ea433f7be582efe6d04d2369e...5327ef918c1f6bc9cadbb7bf900efa80bd1efdbe
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3799362d9a5582ea433f7be582efe6d04d2369e...5327ef918c1f6bc9cadbb7bf900efa80bd1efdbe
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/334da75a/attachment-0001.html>
More information about the ghc-commits
mailing list